Tabelle durchsuchen und Werte kopieren

Forumthread: Tabelle durchsuchen und Werte kopieren

08.03.2007 09:31:31

UweL.

Hallo,
habe mal wieder ein Problem welches ich lösen möchte...
Ich habe eine Tabel mit mehreren Spalten und Zeilen.
Ich möchte jetzt den Bereich von A1 bis G500 durchsuchen.
Wenn ich jetzt den gesuchten Wert finde. Dann soll der Wert rchts davon in eine zweite Tabelle kopiert werden. Der nächste Gesuchte Wert wird dann in der zweiten Tabelle in der Spalte daneben eingefügt usw.
Ich hoffe es ist Verständlich. Ich würde das Makro dann um die Gesuchten Begriffe jeweils erweitern.
Sagen wir einfach für den anfang ich suche Metall und Kupfer und möchte die Werte rechts davon in die nächste Tabelle kopieren.
Viele Dank für alle Hilfen im vorraus...
Gruß
Uwe L.

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Tabelle durchsuchen und Werte kopieren

09.03.2007 05:42:57

fcs
AW: Tabelle durchsuchen und Werte kopieren

09.03.2007 06:47:06

Uwe

AW: Tabelle durchsuchen und Werte kopieren

09.03.2007 05:42:57

fcs

Hallo Uwe,
hier zwei Varianten.
In der 1. Variante kannst du die Suchbegriffe in einer Schleife nacheinander in eine Textbox eingeben.
In der 2. Variante sind die Suchbegriffe fest vorgegeben. Weitere Suchbegriffe kannst du in der Zeile
Suchen = Array("Metall", "Kupfer")
ergänzen
Gruss
Franz

Sub SuchenVar1()
Dim wks1 As Worksheet, wks2 As Worksheet, Zelle As Range, Suchen
Dim Zeile As Long
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
Zeile = 2 'Einfügezeile in Tabelle 2
wks2.Rows(Zeile).ClearContents 'alte Inhalte in Einfügezeile löschen
Do
Suchen = InputBox("Suchbegriff?", "Suche was in Tabelle 1")
If Suchen = "" Then GoTo naechste
Set Zelle = wks1.Range("A1:G500").Find(What:=Suchen, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then
MsgBox ("Suchbegriff '" & Suchen & "' nicht gefunden")
Else
With wks2
If IsEmpty(.Cells(Zeile, 1)) Then
.Cells(Zeile, 1) = Zelle.Offset(0, 1).Value
Else
.Cells(Zeile, .Columns.Count).End(xlToLeft).Offset(0, 1) = Zelle.Offset(0, 1).Value
End If
End With
End If
naechste:
Loop Until MsgBox("Weiter suchen ?", vbYesNo + vbQuestion, "Suche was in Tabelle 1") = vbNo
End Sub
Sub SuchenVar2()
Dim wks1 As Worksheet, wks2 As Worksheet, Zelle As Range, Suchen, i As Integer
Dim Zeile As Long
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
Suchen = Array("Metall", "Kupfer")
Zeile = 2 'Einfügezeile in Tabelle 2
wks2.Rows(Zeile).ClearContents 'alte Inhalte in Einfügezeile löschen
For i = LBound(Suchen) To UBound(Suchen)
Set Zelle = wks1.Range("A1:G500").Find(What:=Suchen(i), LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then
MsgBox ("Suchbegriff '" & Suchen(i) & "' nicht gefunden")
Else
With wks2
If IsEmpty(.Cells(Zeile, 1)) Then
.Cells(Zeile, 1) = Zelle.Offset(0, 1).Value
Else
.Cells(Zeile, .Columns.Count).End(xlToLeft).Offset(0, 1) = Zelle.Offset(0, 1).Value
End If
End With
End If
Next
End Sub

AW: Tabelle durchsuchen und Werte kopieren

09.03.2007 06:47:06

Uwe

Hallo Franz,
vielen Dank für deine beiden Varianten.
Habe beide ausprobiert und beides Funktioniert so wie ich es gerne hätte.
Im Moment favoritisiere ich die zweite Variante. Aber ich habe auch eine Anwendung in
der ich die erste Form gut einsetzen kann.
Also nochmals vielen Dank für deine Hilfe...
Gruß
Uwe

Infobox / Tutorial