AW: Vergleichen und Kopieren von Zeilen (unsortiert)
10.05.2004 23:46:41
Zeilen
Hallo Rolf,
wenn die Spalten B bis D immer verschoben werden sollen, dann versuchs mal hiermit:
Sub Vergleichen_und_Kopieren()
Sheets("Tabelle2").Select
Sheets("Tabelle1").Columns(2).Insert
Sheets("Tabelle1").Columns(2).Insert
Sheets("Tabelle1").Columns(2).Insert
With Worksheets("Tabelle1").Columns(1)
For i = 2 To Cells(65536, 1).End(xlUp).Row
Wert = Cells(i, 1)
Set c = .Find(Wert, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
Range(Cells(i, 1), Cells(i, 3)).Copy Destination:=c(1, 2)
Else
r = .Cells(65536, 2).End(xlUp).Row + 1
Range(Cells(i, 1), Cells(i, 5)).Copy Destination:=.Cells(r, 2)
End If
Next i
End With
End Sub
wenn die Spalten nur verschoben werden sollen, wenn wenigstens eine Übereinstimmung besteht, dann versuchs mal hiermit:
Sub Vergleichen_und_Kopieren()
Treffer=0
Sheets("Tabelle2").Select
With Worksheets("Tabelle1").Columns(1)
For i = 2 To Cells(65536, 1).End(xlUp).Row
Wert = Cells(i, 1)
Set c = .Find(Wert, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
if Treffer=0 then
Sheets("Tabelle1").Columns(2).Insert
Sheets("Tabelle1").Columns(2).Insert
Sheets("Tabelle1").Columns(2).Insert
Treffer=1
end if
Range(Cells(i, 1), Cells(i, 3)).Copy Destination:=c(1, 2)
Else
r = .Cells(65536, 2).End(xlUp).Row + 1
Range(Cells(i, 1), Cells(i, 5)).Copy Destination:=.Cells(r, 2)
End If
Next i
End With
End Sub
wenn nur die Zellen der entsprechenden Zeile nach rechts verschoben werden sollen, dann probiers mal hiermit:
Sub Vergleichen_und_Kopieren()
Sheets("Tabelle2").Select
With Worksheets("Tabelle1").Columns(1)
For i = 2 To Cells(65536, 1).End(xlUp).Row
Wert = Cells(i, 1)
Set c = .Find(Wert, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
Range(.Cells(i, 2), .Cells(i, 4)).Insert shift:=xlShiftToRight
Range(Cells(i, 1), Cells(i, 3)).Copy Destination:=c(1, 2)
Else
r = .Cells(65536, 2).End(xlUp).Row + 1
Range(Cells(i, 1), Cells(i, 5)).Copy Destination:=.Cells(r, 2)
End If
Next i
End With
End Sub
Gruß
Björn