Registername zuordnen - Suchbereich
13.07.2006 15:10:54
Helge
Ich habe eine Arbeitsmappe mit diversen Tabellenblättern (alle sind identisch aufgebaut) und ich möchte nun über einen Button eine Suchfunktion öffnen lassen.
Nach Eingabe meines Suchbegriffes sollen alle Tabellen durchsucht werden (hier möchte ich eine Einschränkung auf einen bestimmten Suchbereich haben A37-CF60 und A74-CF97) und alle Zeilen mit einem Treffer sollen komplett in ein bestimmtes Tabellenblatt kopiert werden. Dort aber erst beginnend ab Zeile 3 (davor sind Überschriften).
Wichtig dabei ist auch, dass eine "Wertkopie" erstellt wird, da viele Einträge in den Zellen aus einer Datenbank kommen. Die Formate (Farbe, Nachkommastellen etc.) sollen dabei ebenfalls übermommen werden. Wichtig ist zudem, dass zu jedem Zeilensatz in der Zieltabelle der Tabellenblattname aus dem die Zeile kommt geschrieben wird (dies soll in der Spalte CG passieren).
Hier mein bisheriger Code:
Sub Suche_Ausgabe_Trefferzeilen()
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String
'Suchbegriff
Dim sFind As Variant
Dim cr As Long, tarWks As String
tarWks = "Zieltabelle" 'Namen der Zieltabelle anpassen
cr = 65536
If Worksheets(tarWks).Cells(cr, 1) = "" Then
cr = Worksheets(tarWks).Cells(cr, 1).End(xlUp).Row
End If
If cr < 3 Then cr = 3 'Den ersten beiden Zeilen ausweichen wg. Überschrift
'If cr = 0 Then cr = 1
'Suchbegriff definieren
sFind = InputBox("Bitte den gewünschten Suchbegriff eingeben:")
If sFind = "" Then Exit Sub
'Suchbegriff auf Zelle definieren
'sFind = Worksheets("Tabelle1").Range("A1")
For Each wks In Worksheets
'If wks.Name = tarWks Then Exit Sub
If wks.Name <> tarWks Then
Set rng = wks.Cells.Find(What:=sFind, _
lookat:=xlPart, LookIn:=xlValues)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
Application.GoTo rng, True
'Für die Automation kann die "If"-Anweisung auskommentiert werden
'If MsgBox("Suchbegriff: " & sFind & ",gefunden in " _
& wks.Name & ", " & rng.Address, vbYesNo + vbQuestion, "Weitersuchen ?") = vbNo Then Exit Sub
wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(cr)
cr = cr + 1
Set rng = wks.Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
NextStart:
End If
Next wks
MsgBox prompt:="Die Suche ist beendet!"
End Sub
Im Grunde bin ich mit dem Ergebnis zufrieden. Nun brauche ich noch folgende Dinge:
1.) In der Zieltabelle sollte in Spalte CG jeweils der Name des Tabellenblattes stehen, damit ich es später zuordnen kann (GANZ WICHTIG)
2.) Die Suche soll auf Bereiche eingeschränkt werden (bei allen Tabellenblättern gleich):
A37-CF60 und A74-CF97
3.) Die Datensätze sollen als "Wertkopie" in der Zieltabelle stehen (sonst gehen mir die Bezüge flöten)
Für diese Punkte brauche ich nun noch eure Hilfe... Danke!