AW: Hilfe?
14.12.2004 09:41:02
Georg
Hallo,
dieser Makro - hier aus dem Forum - müsste Dir weiterhelfen.
Public
Sub Find_double()
' Kopieren der doppelten Einträgen aus Tabelle 1/2 in Tabelle3.
Dim iCol1 As Long
Dim I As Integer
Dim rTabel1, rTabel2, rTemp As Range
Set rTabel1 = Worksheets("Tabelle1").UsedRange
Set rTabel2 = Worksheets("Tabelle2").UsedRange
iCol1 = rTabel1.Columns.Count ' Spaltenanzahl Tabelle 1
' Schleife über alle Zeilen der ersten Tabelle
For I = 2 To rTabel1.Rows.Count
' den Inhalte der ersten Spalte/Tabelle1,
' in der ersten Spalte/Tabelle2 suchen.
Set rTemp = rTabel2.Range(rTabel2.Cells(1, 1), rTabel2.Cells(rTabel2.Rows.Count, 1) _
).Find(What:=rTabel1.Cells(I, 1).Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=True)
' wird ein doppelter Eintrag gefunden, die aktuelle Zeile der
' ersten Tabelle, in die Tabelle 3 kopieren
If Not rTemp Is Nothing Then
rTabel1.Range(rTabel1.Cells(I, 1), rTabel1.Cells(I, iCol1)).Copy _
Destination:=Worksheets("Tabelle3").Cells(I, 1)
End If
Next I
' Die Ergebnistabelle formatieren
Worksheets("Tabelle3").Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Worksheets("Tabelle3").Range("A1").Select
End Sub
Grüße
Georg