Search - Copy - Offset!

The following code is searched for a term and a cell on the right of the find cell is copied in a new sheet. The parameters are optional. Also the find cell, a cell left, right, above or down and/or further can be copied. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in a "Module."

Im folgenden Code wird nach einem Begriff gesucht und eine Zelle rechts der Fundstelle in einem neuen Tabellenblatt ausgegeben. Die Parameter sind Optional. Es kann auch die Fundzelle, eine Zelle links, rechts, oben oder unten bzw. weitere ausgegeben werden. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgede Code gehört in ein "Modul."

Option Explicit
Public Sub Test()
' a cell right - eine Zelle rechts
Call subSearch(, 1)

' the find cell - die FundZelle
'Call subSearch

'a cell right AND down. - eine Zelle rechts UND runter
'Call subSearch(1, 1)

' a cell down
'Call subSearch(-1)

' a cell up - eine Zelle hoch
'Call subSearch(1)

' a cell left - eine Zelle links
'Call subSearch(, -1)

' a cell left AND up - eine Zelle links UND hoch
'Call subSearch(-1, -1)
End Sub
Private Sub subSearch(Optional lngRow As Long = 0, _
Optional lngColumn As Long = 0)
Dim wksSheet As Worksheet
Dim strFound As String
Dim rngFound As Range
Dim strTMP As String
strTMP = InputBox("Search", "Search", "A_1")
If strTMP = "" Then Exit Sub
With Sheet1.Cells
Set rngFound = .Find(What:=strTMP, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
Set wksSheet = Worksheets.Add
strFound = rngFound.Address
If Not rngFound.Row = 1 Or Left(lngRow, 1) <> "-" Then
If Not rngFound.Column = 1 Or _
Left(lngColumn, 1) <> "-" Then
If Not rngFound.Row = .Rows.Count Or _
Left(lngRow, 1) <> "-" Then
If Not rngFound.Column = 1 Or _
Left(lngColumn, 1) <> "-" Then
wksSheet.Range("A" & wksSheet.Rows.Count). _
End(xlUp).Offset _
(1, 0).Value = rngFound.Offset _
(lngRow, lngColumn).Value
End If
End If
End If
End If
Set rngFound = .Cells.FindNext(rngFound)
Loop While rngFound.Address <> strFound
MsgBox "Nothing!"
End If
End With
End Sub

Sample 2003

Sample 2007

Keine Kommentare:

Kommentar veröffentlichen

PowerPoint - Fusszeile - TextBox befüllen - alle Folien...

PowerPoint alle Folien - in der Fusszeile die Textbox befüllen. PowerPoint all slides - fill the text box in the footer. Hier noch eine ...