Vergleichen

Sub Vergleichen() Dim wkb As Workbook Dim wksA As Worksheet, wksB As Worksheet, wksC As Worksheet Dim iWks As Integer, iRow As Integer, iRowT As Integer On Error Resume Next For iWks = 1 To 3 Set wkb = Workbooks("Mappe" & iWks) Next iWks If Err > 0 Or wkb Is Nothing Then Beep Err.Clear MsgBox prompt:="Die 3 Arbeitsmappen sind nicht vorhanden!" Exit Sub End If On Error GoTo 0 Set wksA = Workbooks("Mappe1").Worksheets(1) Set wksB = Workbooks("Mappe2").Worksheets(1) Set wksC = Workbooks("Mappe3").Worksheets(1) iRow = 1 Do Until IsEmpty(wksA.Cells(iRow, 1)) If WorksheetFunction.CountIf( _ wksB.Columns(1), _ wksA.Cells(iRow, 1).Value) = 0 Then iRowT = iRowT + 1 wksC.Cells(iRowT, 1).Value = wksA.Cells(iRow, 1).Value wksC.Cells(iRowT, 2).Value = wksA.Parent.Name End If iRow = iRow + 1 Loop iRow = 1 Do Until IsEmpty(wksB.Cells(iRow, 1)) If WorksheetFunction.CountIf( _ wksA.Columns(1), _ wksB.Cells(iRow, 1).Value) = 0 Then iRowT = iRowT + 1 wksC.Cells(iRowT, 1).Value = wksB.Cells(iRow, 1).Value wksC.Cells(iRowT, 2).Value = wksB.Parent.Name End If iRow = iRow + 1 Loop End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

…du die Xl-Fachterminologie nicht kennst, Chris… :->
Was ist bei dir 'ne Mappe? Die Subprozedur arbeitet mit 3 Mappen (Workbooks), also Dateien, die Mappe1, Mappe2 u. Mappe3 heißen, anderenfalls muss das Makro geändert wdn! Das ist der Nachteil dieser Art zu programmieren.
Von allen diesen Mappen wird stets nur das 1.Blatt (Worksheet) benutzt, egal wie es heißt. Dann wird, bis in Mappe1/Sp.A die 1.Leerzelle kommt, gezählt wie oft der Wert von Mappe1!A1 in Mappe2/Sp.A vorkommt. Wenn er nicht vorkommt, wird hier zuerst der Wert von Mappe!A2 in Mappe3!A2 und in Mappe3!B2 der Name von Mappe1 (hier also „Mappe1”) eingetragen. Dann wird mit der übernächsten bzw, wenn der Wert vorkam, der nächsten Zeile fortgesetzt. Abschließend wird das noch einmal genauso wiederholt.
Wenn das wirklich das ist, was du machen willst, kannst du die Subproz ja anpassen, ansonsten musst du wohl 'ne andere herunterladen… :->
Gruß Luc :-?

Option Explicit Sub Test() Dim WB1 As Workbook, WB2 As Workbook Dim strPathNeue$, booIsOben As Boolean Dim ArrayL1, ArrayL2, ArrayAus() Dim oDic(1) As Object Dim A&, B&, MaxRow& 'neue Preisliste öffnen oder auswählen ChDrive Left$(ThisWorkbook.Path, 3) ChDir ThisWorkbook.Path strPathNeue = Application.GetOpenFilename("Excel (*.xls),*.xls") If strPathNeue = CStr(False) Then Exit Sub Set WB1 = Check_Mappe(strPathNeue) If WB1 Is Nothing Then Set WB1 = Workbooks.Open(strPathNeue, ReadOnly:=True) Else booIsOben = True End If 'alte Preisliste Mappe (= diese Preisliste) Set WB2 = ThisWorkbook 'neue Preisliste With WB1.Sheets("Artikel") MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row If MaxRow < 2 Then 'keine Daten MsgBox "keine Daten in '" & WB1.Name & "' gefunden!", vbExclamation If Not booIsOben Then WB1.Close Exit Sub End If ArrayL1 = .Range("A1", .Cells(MaxRow, 1)).Resize(, 4) End With If Not booIsOben Then WB1.Close 'alte Preisliste With WB2.Sheets("Artikel") MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row If MaxRow < 2 Then 'keine Daten MsgBox "keine Daten in '" & WB2.Name & "' gefunden!", vbExclamation Exit Sub End If ArrayL2 = .Range("A1", .Cells(MaxRow, 1)).Resize(, 4) End With Set oDic(0) = CreateObject("Scripting.Dictionary") Set oDic(1) = CreateObject("Scripting.Dictionary") 'Daten Sammeln aus neuer Liste For A = 2 To Ubound(ArrayL1) oDic(0)(ArrayL1(A, 1) & ArrayL1(A, 4)) = 0 Next A 'Daten Sammeln aus alter Liste For A = 2 To Ubound(ArrayL2) oDic(1)(ArrayL2(A, 1) & ArrayL2(A, 4)) = 0 Next A 'neues Array groß genug erstellen Redim Preserve ArrayAus(1 To Application.Max(Ubound(ArrayL1), Ubound(ArrayL2)) + 1, 1 To 5) 'Überschrift B = 1 ArrayAus(B, 1) = ArrayL2(1, 1) ArrayAus(B, 2) = ArrayL2(1, 2) ArrayAus(B, 3) = ArrayL2(1, 3) ArrayAus(B, 4) = ArrayL2(1, 4) ArrayAus(B, 5) = "Info" 'geänderte Daten Suchen in alte Liste For A = 2 To Ubound(ArrayL1) If Not oDic(1).exists(ArrayL1(A, 1) & ArrayL1(A, 4)) Then B = B + 1 ArrayAus(B, 1) = ArrayL1(A, 1) ArrayAus(B, 2) = ArrayL1(A, 2) ArrayAus(B, 3) = ArrayL1(A, 3) ArrayAus(B, 4) = ArrayL1(A, 4) ArrayAus(B, 5) = "fehlt in alt" End If Next A 'geänderte Daten Suchen in neue Liste For A = 2 To Ubound(ArrayL2) If Not oDic(0).exists(ArrayL2(A, 1) & ArrayL2(A, 4)) Then B = B + 1 ArrayAus(B, 1) = ArrayL2(A, 1) ArrayAus(B, 2) = ArrayL2(A, 2) ArrayAus(B, 3) = ArrayL2(A, 3) ArrayAus(B, 4) = ArrayL2(A, 4) ArrayAus(B, 5) = "fehlt in neu" End If Next A 'Ausgabe in neue Datei If B > 1 Then With Application .ScreenUpdating = False .EnableEvents = False With Workbooks.Add With .Sheets(1) With .Range("A1").Resize(Ubound(ArrayAus), Ubound(ArrayAus, 2)) .Value = ArrayAus 'Daten einfügen .Rows(1).Font.Bold = True 'Zeile 1 fett .EntireColumn.WrapText = False 'ohne Zeilenumbruch .Columns(4).NumberFormat = "0.00" 'Währungsformat .EntireColumn.ColumnWidth = 15 'Spaltenbreite .Columns(1).EntireColumn.AutoFit 'Spalte1 optimal breite .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _ Key2:=.Cells(1, 5), Order1:=xlAscending, Header:=xlYes 'nach Spalte 1 sortieren End With 'Range("A1").Resize End With 'Sheets(1) End With 'Workbooks.Add .ScreenUpdating = True .EnableEvents = True End With 'Application Else MsgBox "Es konnten keine Unterschiede festgestellt werden.", vbInformation End If End Sub Function Check_Mappe(strFullName$) As Workbook Dim oWB As Workbook For Each oWB In Application.Workbooks If oWB.FullName = strFullName Then Set Check_Mappe = oWB Exit For End If Next End Function

Sub doppelte() Dim lngZeile As Long Dim lngZeilenSprung As Long Dim strSuchwert As String lngZeile = Cells(Rows.Count, 1).End(xlUp).Row For lngZeilenSprung = lngZeile To 4 Step -1 strSuchwert = Cells(lngZeilenSprung, 1).Value If Application.WorksheetFunction.CountIf(Range(Cells(2, 1), _ Cells(lngZeile, 1)), strSuchwert) 1 Then Cells(lngZeilenSprung, 1).Interior.ColorIndex = 36 End If Next lngZeilenSprung End Sub

Hallo,
habe ich dich richtig verstanden?
Aus den Preislisten sollen die doppelten zuerst raus gelöscht werden.
Dieser Code sollte die wirklich doppelten Zeilen löschen und in die Liste(n) zurückschreiben und speichern.
Die entsprechenden Zeilen sind im Code kommentiert.
Danach erfolgt der Vergleich der beiden Listen.
Bitte erst an einer Kopie testen!!!

Option Explicit

Sub Test()
Dim WB1 As Workbook, WB2 As Workbook
Dim strPathNeue$, booIsOben As Boolean
Dim ArrayL1, ArrayL2, ArrayAus()
Dim oDic(1) As Object
Dim A&, B&, MaxRow&
Dim tmpString$

'neue Preisliste öffnen oder auswählen 
ChDrive Left$(ThisWorkbook.Path, 3)
ChDir ThisWorkbook.Path
strPathNeue = Application.GetOpenFilename("Excel (*.xls),*.xls")

If strPathNeue = CStr(False) Then Exit Sub

Set WB1 = Check_Mappe(strPathNeue)
If WB1 Is Nothing Then
    Set WB1 = Workbooks.Open(strPathNeue)
Else
    booIsOben = True
End If

'alte Preisliste Mappe (= diese Preisliste) 
Set WB2 = ThisWorkbook

'neue Preisliste 
With WB1.Sheets("Artikel")
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If MaxRow < 2 Then 'keine Daten 
        MsgBox "keine Daten in '" & WB1.Name & "' gefunden!", vbExclamation
        If Not booIsOben Then WB1.Close
        Exit Sub
    End If
    ArrayL1 = .Range("A1", .Cells(MaxRow, 1)).Resize(, 4)
End With

'alte Preisliste 
With WB2.Sheets("Artikel")
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If MaxRow < 2 Then 'keine Daten 
        MsgBox "keine Daten in '" & WB2.Name & "' gefunden!", vbExclamation
        If Not booIsOben Then WB1.Close
        Exit Sub
    End If
    ArrayL2 = .Range("A1", .Cells(MaxRow, 1)).Resize(, 4)
End With

'doppelte löschen aus neuer Liste ________________________________________
B = 0 
Set oDic(0) = CreateObject("Scripting.Dictionary")
Redim Preserve ArrayAus(1 To Ubound(ArrayL1), 1 To 4)
For A = 2 To Ubound(ArrayL1)
    tmpString = ArrayL1(A, 1) & ArrayL1(A, 2) & ArrayL1(A, 3) & ArrayL1(A, 4)
    If Not oDic(0).exists(tmpString) Then
        B = B + 1
        ArrayAus(B, 1) = ArrayL1(A, 1)
        ArrayAus(B, 2) = ArrayL1(A, 2)
        ArrayAus(B, 3) = ArrayL1(A, 3)
        ArrayAus(B, 4) = ArrayL1(A, 4)
        oDic(0)(tmpString) = 0
    End If
Next A
Set oDic(0) = Nothing
If B > 1 Then
    With WB1.Sheets("Artikel")
        .Range("A2").Resize(Ubound(ArrayAus), 4) = ArrayAus
    End With
    WB1.Save 'speichern ? 
End If
Erase ArrayAus

'doppelte löschen aus alter Liste 
B = 0
Set oDic(0) = CreateObject("Scripting.Dictionary")
Redim Preserve ArrayAus(1 To Ubound(ArrayL2), 1 To 4)
For A = 2 To Ubound(ArrayL2)
    tmpString = ArrayL2(A, 1) & ArrayL2(A, 2) & ArrayL2(A, 3) & ArrayL2(A, 4)
    If Not oDic(0).exists(tmpString) Then
        B = B + 1
        ArrayAus(B, 1) = ArrayL2(A, 1)
        ArrayAus(B, 2) = ArrayL2(A, 2)
        ArrayAus(B, 3) = ArrayL2(A, 3)
        ArrayAus(B, 4) = ArrayL2(A, 4)
        oDic(0)(tmpString) = 0
    End If
Next A
Set oDic(0) = Nothing
If B > 1 Then
    With WB2.Sheets("Artikel")
        .Range("A2").Resize(Ubound(ArrayAus), 4) = ArrayAus
    End With
    WB2.Save 'speichern ? 
End If
Erase ArrayAus
'********************************************************************************* 

'neue Preisliste nochmals neu aufnehmen __________________________________________
With WB1.Sheets("Artikel") 
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If MaxRow < 2 Then 'keine Daten 
        MsgBox "keine Daten in '" & WB1.Name & "' gefunden!", vbExclamation
        If Not booIsOben Then WB1.Close
        Exit Sub
    End If
    ArrayL1 = .Range("A1", .Cells(MaxRow, 1)).Resize(, 4)
End With

'alte Preisliste nochmals neu aufnehmen 
With WB2.Sheets("Artikel")
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If MaxRow < 2 Then 'keine Daten 
        MsgBox "keine Daten in '" & WB2.Name & "' gefunden!", vbExclamation
        If Not booIsOben Then WB1.Close
        Exit Sub
    End If
    ArrayL2 = .Range("A1", .Cells(MaxRow, 1)).Resize(, 4)
End With


'********************************************************************************** 

Set oDic(0) = CreateObject("Scripting.Dictionary")
Set oDic(1) = CreateObject("Scripting.Dictionary")

'Daten Sammeln aus neuer Liste 
For A = 2 To Ubound(ArrayL1)
    oDic(0)(ArrayL1(A, 1) & ArrayL1(A, 4)) = 0
Next A

'Daten Sammeln aus alter Liste 
For A = 2 To Ubound(ArrayL2)
    oDic(1)(ArrayL2(A, 1) & ArrayL2(A, 4)) = 0
Next A

If Not booIsOben Then WB1.Close

'neues Array groß genug erstellen 
Redim Preserve ArrayAus(1 To Application.Max(Ubound(ArrayL1), Ubound(ArrayL2)) + 1, 1 To 5)

'Überschrift 
B = 1
ArrayAus(B, 1) = ArrayL2(1, 1)
ArrayAus(B, 2) = ArrayL2(1, 2)
ArrayAus(B, 3) = ArrayL2(1, 3)
ArrayAus(B, 4) = ArrayL2(1, 4)
ArrayAus(B, 5) = "Info"

'geänderte Daten Suchen in alte Liste 
For A = 2 To Ubound(ArrayL1)
    If Not oDic(1).exists(ArrayL1(A, 1) & ArrayL1(A, 4)) Then
        B = B + 1
        ArrayAus(B, 1) = ArrayL1(A, 1)
        ArrayAus(B, 2) = ArrayL1(A, 2)
        ArrayAus(B, 3) = ArrayL1(A, 3)
        ArrayAus(B, 4) = ArrayL1(A, 4)
        ArrayAus(B, 5) = "fehlt in alt"
    End If
Next A

'geänderte Daten Suchen in neue Liste 
For A = 2 To Ubound(ArrayL2)
    If Not oDic(0).exists(ArrayL2(A, 1) & ArrayL2(A, 4)) Then
        B = B + 1
        ArrayAus(B, 1) = ArrayL2(A, 1)
        ArrayAus(B, 2) = ArrayL2(A, 2)
        ArrayAus(B, 3) = ArrayL2(A, 3)
        ArrayAus(B, 4) = ArrayL2(A, 4)
        ArrayAus(B, 5) = "fehlt in neu"
    End If
Next A

'Ausgabe in neue Datei 
If B > 1 Then
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        
        With Workbooks.Add
            With .Sheets(1)
                With .Range("A1").Resize(Ubound(ArrayAus), Ubound(ArrayAus, 2))
                    .Value = ArrayAus 'Daten einfügen 
                    .Rows(1).Font.Bold = True 'Zeile 1 fett 
                    .EntireColumn.WrapText = False 'ohne Zeilenumbruch 
                    .Columns(4).NumberFormat = "0.00" 'Währungsformat 
                    .EntireColumn.ColumnWidth = 15 'Spaltenbreite 
                    .Columns(1).EntireColumn.AutoFit 'Spalte1 optimal breite 
                    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
                          Key2:=.Cells(1, 5), Order1:=xlAscending, Header:=xlYes 'nach Spalte 1 sortieren 
                End With 'Range("A1").Resize 
            End With 'Sheets(1) 
        End With 'Workbooks.Add 
        
        .ScreenUpdating = True
        .EnableEvents = True
    End With 'Application 
Else
    MsgBox "Es konnten keine Unterschiede festgestellt werden.", vbInformation
End If
End Sub

Function Check_Mappe(strFullName$) As Workbook
Dim oWB As Workbook
For Each oWB In Application.Workbooks
    If oWB.FullName = strFullName Then
        Set Check_Mappe = oWB
        Exit For
    End If
Next
End Function

Gruß Tino

Beliebteste Forumthreads (12 Monate)

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread