AW: Zwei Dateien vergleichen
18.06.2009 23:48:02
Josef
Hallo Peter,
als Ansatz.
' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub DatenVergleich()
Dim objWB1 As Workbook, objWB2 As Workbook
Dim objWS As Worksheet
Dim lngIndex As Long, lngLast As Long, lngRow As Long
Dim varV1 As Variant, varV2 As Variant, varResult As Variant
On Error GoTo ErrExit
GMS
Set objWB1 = Workbooks.Open("E:\Office\Excel\Forum\Test\Datei1.xls") 'erste Datei - Name&Pfad anpassen!
Set objWB2 = Workbooks.Open("E:\Office\Excel\Forum\Test\Datei2.xls") 'erste Datei - Name&Pfad anpassen!
lngLast = Application.Max(2, objWB1.Sheets("Tabelle1").Cells(Rows.Count, 4).End(xlUp).Row, objWB2.Sheets("Tabelle1").Cells(Rows.Count, 4).End(xlUp).Row)
varV1 = objWB1.Sheets("Tabelle1").Range("D2:D" & lngLast)
varV2 = objWB2.Sheets("Tabelle1").Range("D2:D" & lngLast)
Redim varResult(1 To lngLast + 1, 1 To 2)
objWB1.Close
objWB2.Close
varResult(1, 1) = "Datei 1"
varResult(1, 2) = "Datei 2"
lngRow = 2
For lngIndex = 1 To UBound(varV1, 1)
If varV1(lngIndex, 1) <> varV2(lngIndex, 1) Then
varResult(lngRow, 1) = varV1(lngIndex, 1)
varResult(lngRow, 2) = varV2(lngIndex, 1)
lngRow = lngRow + 1
End If
Next
With ThisWorkbook.Sheets("Tabelle1")
.Range("A1:B" & lngLast + 1) = varResult
End With
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (DatenVergleich) in Modul Modul4", _
vbExclamation, "Fehler in Modul4 / DatenVergleich"
End With
GMS True
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Gruß Sepp