AW: Vergleich von zwei Dateien
01.05.2008 14:45:56
zwei
Hallo Michael,
ich hoffe, ich habe Deine Frage richtig verstanden. Mein Vorschlag:
Verglichen werden sollen die Inhalte von Arbeitsmappe1, Tabelle 1 und Arbeitsmappe2, Tabelle1. Zeilen der Tabellen, die voneinander abweichen, werden geschrieben nach Arbeitsmappe1, Tabelle2 und Arbeitsmappe2, Tabelle2. Die Inhalte der Zellen der Tabellen2, die voneinander abweichen, werden rot dargestellt.
Die Makros "Vergleichen()" und "WkbExists()" befindet sich in beiden Arbeitsmappen, so dass der Vergleich aus jeder der Arbeitsmappen gestartet werden kann.
Zunächst wird geprüft, ob Arbeitsmappe1 bzw. Arbeitsmappe2 geöffnet sind. Wenn nicht, dann wird der Dialog zum Dateiöffnet aufgerufen und anschliessend der Vergleich durchgeführt.
Sub Vergleichen()
Dim oWS1_1 As Object, oWS1_2 As Object, oWS2_1 As Object, oWS2_2 As Object
Dim bCol As Byte, iRow As Integer, iRow2 As Integer
Dim sTab1 As String, sTab2 As String
On Error GoTo abbruch
If ActiveWorkbook.Name = "Arbeitsmappe1.xls" Then
WkbExists "Arbeitsmappe2.xls"
ElseIf ActiveWorkbook.Name = "Arbeitsmappe2.xls" Then
WkbExists "Arbeitsmappe1.xls"
End If
On Error GoTo 0
Set oWS1_1 = Excel.Application.Workbooks("Arbeitsmappe1.xls").Worksheets("Tabelle1")
Set oWS1_2 = Excel.Application.Workbooks("Arbeitsmappe1.xls").Worksheets("Tabelle2")
Set oWS2_1 = Excel.Application.Workbooks("Arbeitsmappe2.xls").Worksheets("Tabelle1")
Set oWS2_2 = Excel.Application.Workbooks("Arbeitsmappe2.xls").Worksheets("Tabelle2")
oWS1_2.UsedRange.Delete
oWS2_2.UsedRange.Delete
iRow2 = 1
For iRow = 1 To oWS1_1.Cells(Rows.Count, 1).End(xlUp).Row
sTab1 = ""
sTab2 = ""
For bCol = 1 To oWS1_1.Cells(1, Columns.Count).End(xlToLeft).Column
sTab1 = sTab1 + Format(oWS1_1.Cells(iRow, bCol))
sTab2 = sTab2 + Format(oWS2_1.Cells(iRow, bCol))
Next bCol
If sTab1 sTab2 Then
For bCol = 1 To oWS1_1.Cells(1, Columns.Count).End(xlToLeft).Column
oWS1_2.Cells(iRow2, bCol) = oWS1_1.Cells(iRow, bCol)
oWS2_2.Cells(iRow2, bCol) = oWS2_1.Cells(iRow, bCol)
Next bCol
iRow2 = iRow2 + 1
End If
Next iRow
For iRow = 1 To oWS1_2.Cells(Rows.Count, 1).End(xlUp).Row
For bCol = 1 To oWS1_2.Cells(1, Columns.Count).End(xlToLeft).Column
If oWS1_2.Cells(iRow, bCol).Value oWS2_2.Cells(iRow, bCol).Value Then
oWS1_2.Cells(iRow, bCol).Font.ColorIndex = 3
oWS2_2.Cells(iRow, bCol).Font.ColorIndex = 3
End If
Next bCol
Next iRow
GoTo ende
abbruch:
MsgBox ("Keine Arbeitsmappe zum Vergleich ausgewählt")
ende:
End Sub
Sub WkbExists(sName As String)
Dim bExists As Boolean, objWorkbook As Object
bExists = False
For Each objWorkbook In Application.Workbooks
If objWorkbook.Name = sName Then
bExists = True
Exit For
End If
Next objWorkbook
If bExists = False Then
sName = Application.GetOpenFilename("Excel-Dateien(*.xls), *.xls")
Workbooks.Open Filename:=sName, ReadOnly:=False
End If
End Sub