AW: Spalten nach Text durchsuchen
19.01.2009 13:48:00
fcs
Hallo Kall,
hier mein Vorschlag.
Die Namen der Quell- und Zieltabelle muss du ggf. noch anpassen.
Gruß
Franz
Sub Suchen_UA()
Call Suchen_Kopieren(wksQuelle:=Worksheets("Tabelle1"), wksZiel:=Worksheets("Tabelle5"), _
varSuchen:="UA", Spalte:=1, ZeileStart:=16)
End Sub
Sub Suchen_Kopieren(wksQuelle As Worksheet, wksZiel As Worksheet, varSuchen, _
Optional Spalte As Long = 1, Optional ZeileStart As Long = 1)
'Durchsucht eine Spalte der Quelltabelle nach dem Suchbegriff und _
kopiert gefundene Zeilen in die Zieltabelle. Gesucht wird nach Übereinstimmumg _
des gesamten Zellwertes
'wksQuelle = Tabellenblatt in dem gesucht werden soll
'wksZiel = Tabelle in die die gefundenen Zeilen kopiert werden sollen
'varSuchen = Suchbegriff
'Spalte = Nr. der zu durchsuchenden Spalte
'ZeileStart = Nr. der Zeile ab der gesucht werden soll
Dim rngZelle As Range, ZeileZiel As Long, strZelle1 As String, rngBereich As Range
Dim ZeileLetzte As Long
'letzte Datenzeile in Zieltabelle Spalte A
With wksZiel
ZeileZiel = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With wksQuelle
'letzte Datenzeile in Suchspalte der Quelltabelle
ZeileLetzte = .Cells(.Rows.Count, Spalte).End(xlUp).Row
If ZeileLetzte >= ZeileStart Then
'Suchbereich setzen
Set rngBereich = .Range(.Cells(16, Spalte), .Cells(ZeileLetzte, 16))
'Suchbegriff suchen
Set rngZelle = rngBereich.Find(What:=varSuchen, LookIn:=xlValues, _
lookat:=xlWhole)
If rngZelle Is Nothing Then
MsgBox "Suchbegriff """ & varSuchen & """ nicht gefunden!"
Else
'1. Fundstelle merken
strZelle1 = rngZelle.Address
Do
ZeileZiel = ZeileZiel + 1
rngZelle.EntireRow.Copy Destination:=wksZiel.Cells(ZeileZiel, 1)
'nächste Fundstelle suchen
Set rngZelle = rngBereich.FindNext(After:=rngZelle)
Loop Until rngZelle.Address = strZelle1
wksZiel.Activate
MsgBox "Fertig mit Suchen und Kopieren"
End If
Else
MsgBox "Keine Daten im Suchbereich der Quell-Tabelle"
End If
End With
End Sub