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
Do
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
Else
MsgBox "Nothing!"
End If
End With
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...