AW: nicht vorhande Zeilen kopieren zw. 2 Dateien
15.08.2007 14:07:45
Chaos
Servus Rolf,
probiers mal damit:
Sub suche()
Dim reihe As Long, reihe1 As Long, zeile1 As Long, row1 As Long, zeile As Long
Dim quelle As String, ziel As String, suche As String, speicher As String
Dim zelle As Range, bereich As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
quelle = ThisWorkbook.Name
reihe = Workbooks(quelle).Sheets(1).Range("A65536").End(xlUp).Offset(0, 0).Row
Sheets.Add After:=Sheets(1)
speicher = ActiveSheet.Name
With Workbooks(quelle).Sheets(1)
For zeile = 2 To reihe Step 1
.Cells(zeile, 1).EntireRow.Copy Sheets(speicher).Cells(zeile, 1)
Next zeile
End With
Workbooks.Open Filename:="C:\Dokumente und Einstellungen\Christian\Desktop\B.xls"
ziel = ActiveWorkbook.Name
reihe1 = Workbooks(ziel).Sheets(1).Range("A65536").End(xlUp).Offset(0, 0).Row
With Workbooks(ziel).Sheets(1)
For zeile1 = 2 To reihe1 Step 1
suche = .Cells(zeile1, 1).Value
With Workbooks(quelle).Sheets(speicher)
Dim rspeicher As Long, zspeicher As Long
rspeicher = .Range("A65536").End(xlUp).Offset(0, 0).Row
For zspeicher = rspeicher To 2 Step -1
If .Cells(zspeicher, 1).Value = suche Then
.Cells(zspeicher, 1).EntireRow.Delete
End If
Next zspeicher
End With
Next zeile1
End With
With Workbooks(quelle).Sheets(speicher)
Dim reihespeicher As Long, zeilespeicher As Long
reihespeicher = .Range("A65536").End(xlUp).Offset(0, 0).Row
For zeilespeicher = 2 To reihespeicher Step 1
.Cells(zeilespeicher, 1).EntireRow.Copy Workbooks(ziel).Sheets(1).Range("A65536") _
.End(xlUp).Offset(1, 0)
Next zeilespeicher
End With
Workbooks(quelle).Sheets(speicher).Delete
Workbooks(ziel).Save
Workbooks(ziel).Close
Workbooks(quelle).Sheets(1).Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
kurze Anmerkung:
Makro in Datei A, es werden die Daten aus Sheet(1), die nicht in Datei B.Sheet(1) sind, nach Datei B.Sheet(1) kopiert.
Dabei wird B durch Ausführung des Makros automatisch geöffnet, gespeichert und wieder geschlossen, also Pfad anpassen (Workbooks.Open....)
Gruß
Chaos