AW: Dein Problem könnte sehr wohl sein, dass...
25.07.2011 14:34:27
Tino
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