AW: Listen kombinieren
21.04.2010 08:42:27
Dirk
Hallo Mat,
hier das Makro mit Abspeichern der Altliste. Alle Aenderungen erfolgen dann in der Kopie.
Lass' von Dir hoeren, ob ok.
Gruss
Dirk aus Dubai
Diese drei Zeilen als erste Zeilen in das Modul kopieren, danach das Macro!
Option Explicit
Global MyArray1(15) 'Hier den Wert fuer die Anzahl der spalten setzen, welche uebernommen werden sollen
Global MyArray2(15)
hier jetzt das Makro:
Sub NeueListe()
Dim StartRow As Long, LastRow As Long, MyRange As Range, TmpStr As String
Dim X As Long, NeuDatei As String, NeuListe As String, AltListe As String
Dim AltDatei As String, Datei1 As String, Datei2 As String, RefListe As String, SourceListe As _
String
Dim MyFind As Object, Verschieden As Boolean, sFilter As String
Dim i As Long, Ursprung As Long, Alt As Boolean
'lege Kopie der aktuellen Liste an, damit alte Liste ohne Aenderungen weiter besteht
ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Mid(ThisWorkbook.Name, 1, 7) & _
"_Update_" & Day(Date) & Month(Date) & Year(Date) & ".xls"
'Neue Liste zur Einarbeitung ueber Benutzerdialog auswaehlen
sFilter = "Excel (*.xls),*.xls"
NeuDatei = Application.GetOpenFilename(sFilter, , Title:="Bitte neue Liste zur Einarbeitung _
auswaehlen", Buttontext:="Einarbeiten", MultiSelect:=False)
'They have cancelled.
If NeuDatei = "False" Then Exit Sub
NeuListe = "Neuliste" 'hier Blattname als string
AltListe = "AltListe"
AltDatei = ActiveWorkbook.Name
'bestimme variablen
StartRow = 4 'hier Zeilennummer der ersten Zeile festlegen
LastRow = ActiveSheet.Range("A65536").End(xlUp).Row 'funktioniert nur fuer sichtbare _
Zellen, nicht fuer ausgeblendete Zeilen!
Workbooks.Open Filename:=NeuDatei
Sheets(NeuListe).Select
NeuDatei = ActiveWorkbook.Name
Alt = False
'erster Durchlauf mit Altliste Artikelnummern als referenz
Workbooks(AltDatei).Sheets(AltListe).Activate
LastRow = ActiveSheet.Range("A65536").End(xlUp).Row 'funktioniert nur fuer sichtbare _
Zellen, nicht fuer ausgeblendete Zeilen!
Workbooks(NeuDatei).Sheets(NeuListe).Activate
RefListe = AltListe
SourceListe = NeuListe
Datei1 = NeuDatei
Datei2 = AltDatei
Ursprung = 1
GoTo Durchlauf
1:
'zweiter Durchlauf mit Neuliste als Referenz
Workbooks(NeuDatei).Sheets(NeuListe).Activate
LastRow = ActiveSheet.Range("A65536").End(xlUp).Row
Workbooks(AltDatei).Sheets(AltListe).Activate
RefListe = NeuListe
SourceListe = AltListe
Datei1 = AltDatei
Datei2 = NeuDatei
Ursprung = 2
GoTo Durchlauf
2:
'Finished
MsgBox "Die Liste wurde aktualisiert. Nicht fortgesetzte Eintraege sind Rot markiert," & vbCrLf _
& _
"geaenderte eintraege sind Gelb markiert, neue Artikel sind am ende der Liste angefuegt ( _
Sortierung notwendig)"
Application.EnableEvents = False
Application.DisplayAlerts = False
Workbooks(NeuDatei).Close SaveChanges:=False
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Durchlauf:
For X = LastRow To StartRow Step -1
Verschieden = False
If Workbooks(Datei2).Sheets(RefListe).Cells(X, 1).Interior.ColorIndex -4142 Then
'Reihe is eingefaerbt, pruefe ob ROT
If Workbooks(Datei2).Sheets(RefListe).Cells(X, 1).Interior.ColorIndex = 3 Then
'alter Eintrag ohne entsprechenden Wert in neuer liste (discontinued)
Alt = True
Else
'alter Eintrag mit neuen Daten in neuer Liste (GELB)
End If
End If
TmpStr = Workbooks(Datei2).Sheets(RefListe).Cells(X, 1).Value
If TmpStr = "" Then GoTo Skip
Set MyRange = Range("A1:A" & Range("A65536").End(xlUp).Row)
With MyRange
Set MyFind = .Find(What:=TmpStr, LookIn:=xlValues, searchdirection:=xlRows)
If Not MyFind Is Nothing Then 'Artikelnummer in beiden Tabellen
If Not Ursprung = 2 Then
For i = 1 To 15
MyArray1(i) = Workbooks(Datei1).Sheets(SourceListe).Cells(MyFind.Row, i). _
Value
MyArray2(i) = Workbooks(Datei2).Sheets(RefListe).Cells(X, i).Value
'vergleiche arrays
If MyArray1(i) MyArray2(i) Then Verschieden = True 'unterschiede in _
Artikelnummerdatensaetzen
Next i
If Verschieden = True Then
'kopiere Zeile vonNeuliste nach Altliste
ThisWorkbook.Sheets(AltListe).Cells(X, 1).Offset(1).EntireRow.Insert
For i = 1 To 15
ThisWorkbook.Sheets(AltListe).Cells(X, i).Offset(1, 0) = MyArray1(i)
'myarrayneu(i) = ""
'myarrayalt(i) = ""
Next i
ThisWorkbook.Sheets(AltListe).Cells(X, 1).EntireRow.Interior.ColorIndex = 6 _
'Gelb,
Verschieden = False
End If
End If
Else 'nicht in neuer Liste gefunden, Artikel nicht fortgesetzt/geloescht?
If Ursprung = 1 And Alt = False Then 'Nur markieren falls nicht in Neuliste und _
noch nicht markiert
Workbooks(AltDatei).Sheets(AltListe).Cells(X, 1).EntireRow.Interior.ColorIndex = _
3 'ROT, nicht mehr in NEU vorhanden
ElseIf Ursprung = 2 Then
'kopiere Zeile vonNeuliste nach Altliste
ThisWorkbook.Sheets(AltListe).Cells(Range("A65536").End(xlUp).Row + 1, 1).Offset( _
1).EntireRow.Insert
Workbooks(NeuDatei).Sheets(NeuListe).Cells(X, 1).EntireRow.Copy Destination:= _
ThisWorkbook.Sheets(AltListe).Cells(Range("A65536").End(xlUp).Row + 1, 1)
Selection.Interior.ColorIndex = 2 'Gruen
Application.CutCopyMode = False
End If
End If
End With
Skip:
Next X
If Ursprung = 1 Then
GoTo 1
ElseIf Ursprung = 2 Then
GoTo 2
End If
End Sub