@MAT wg. Liste kombinieren

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
If Verschieden = True Then Exit For
Next i
If Verschieden = True Then
'kopiere Zeile vonNeuliste nach Altliste
ThisWorkbook.Sheets(AltListe).Cells(X, 1).Offset(1).EntireRow.Insert
Workbooks(NeuDatei).Sheets(NeuListe).Cells(MyFind.Row, 1).EntireRow.Copy  _
Destination:=ThisWorkbook.Sheets(AltListe).Cells(X + 1, 1)
' 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