Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1152to1156
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Listen kombinieren

Listen kombinieren
Mat
Hallo Excelforum,
ich bräuchte Euere Hilfe. Ich habe zwei sehr umfangreiche Excellisten. Die erste nenne ich "Alte" die zweite "Neue". In Spalte A steht jeweils eine eindeutige Artikelnummer.
Aus beiden möchte ich eine neue Gesamtliste generieren. Bei identischen Artikelnummern soll jeweils die Zeile von "Neue" übernommen werden, da sich vermutlich die Daten in der Zeile geändert haben.
Die Artikelnummern aus Alte, welche in Neue nicht mehr vorkommen sollen ebenfalls übernommen und die Werte/Zeile nach Möglichkeit farblich (z. B. rot) gekennzeichnet werden. Die neuen Artikelnummern aus Neue soll mit allen Werten aus der Zeile, welche in "Alte" noch ja nicht vorhanden waren, sollen ebenfalls in die Gesamtliste, (wenn möglich in einer anderen Farbe z. B. blau) übernommen werden.
Vielen Dank für Euere Bemühungen...
Gruß Mat

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: nur in einer Spalte
19.04.2010 20:35:05
Mat
Hallo WF,
damit komme ich leider nicht weiter. Ich habe auch ähnliche Beispiele im Forum gefunden, aber keines hat das eigentlich gewünschte Ergebnis ohne größere Nacharbeit erbracht. Da ich diese Zusammenstellung recht häufig vornehmen muss, wäre eine passende Funktion eine echte Erleichtung für mich.
Wäre tol,l wenn jemand doch noch ein abgestimmtes Makro zaubern könnte.
Viele Grüße
Mat
Anzeige
AW: Listen kombinieren
20.04.2010 12:14:28
Dirk
Hallo Mat,
Schau mal ob das hier weiterhilft:
Option Explicit
Global MyArray1(15) 'Hier den Wert fuer die Anzahl der spalten setzen, welche uebernommen werden sollen
Global MyArray2(15)
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
Dim i As Long, Ursprung As Long
'bestimme variablen
StartRow = 4    'hier Zeilennummer der ersten Zeile festlegen
NeuDatei = "D:\My Documents\Neuliste.xls"  'hier dateiname mit komplettem Pfad as String  _
eintragen
NeuListe = "Neuliste"  'hier Blattname als string
AltListe = "AltListe"
AltDatei = ActiveWorkbook.Name
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
'erster Durchlauf mit Altliste Artikelnummern als referenz
ThisWorkbook.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. Obsolete Eintraege Rot, geaenderte eintraege Gelb"
Application.DisplayAlerts = False
Workbooks(NeuDatei).Close Savechanges:=False
Application.DisplayAlerts = True
Exit Sub
Durchlauf:
For X = LastRow To StartRow Step -1
Verschieden = False
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 NEU gefunden
If Ursprung = 1 Then    'Nur markieren falls nicht in Neuliste
ThisWorkbook.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)
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
Alles in ein Modul kopieren und die Variablen entsprechend Deinen Daten anpassen.
Das Makro aktualisiert Deine Altlitse mit den Werten aus der neuen Liste.
Gruss
Dirk aus Dubai
Anzeige
AW: Listen kombinieren
20.04.2010 12:34:17
Dirk
Hallo Nochmal,
hier noch ein Nachtrag, damit nicht die alten Zeilen beruecksichtigt werden:
For X = LastRow To StartRow Step -1
Verschieden = False
If Workbooks(Datei2).Sheets(RefListe).Cells(X, 1).Interior.ColorIndex -4142 Then
GoTo Skip
End If
Diesen code noch im Durchlauf aendern.
Lass' mal hoeren, ob ok.
Gruss
Dirk aus Dubai
AW: Listen kombinieren
20.04.2010 15:16:37
Mat
Hallo Dirk,
ich bekomme einen Fehler bei MyArray1(i) = Sub oder Funktion nicht definiert.
Wenn ich den Code richtig verstehe wird eine neue Exceldatei angelegt. Mir würde ein neues Tabellenblatt völlig genügen.
Gruß Mat
Anzeige
AW: Listen kombinieren
20.04.2010 15:22:06
Dirk
Hallo!
Du must die Arrays als global definieren (ausserhalb des subs.
gehe mal in das Modul, finde dort OptionExpicit
und schreibe darunter folgende 2 zeilen:
Global MyArray1(15)
Global MyArray2(15)
Dann sollte das durchlaufen. Falls nicht bitte nochmal posten.
Gruss
Dirk aus Dubai
AW: Listen kombinieren
20.04.2010 18:53:59
Mat
Hi Dirk,
das Makro läuft zwar jetzt durch, aber ich bekomme nicht das gewünschte Ergebnis.
Es werden nicht alle Werte zusammengefasst. Außerdem wird die Liste Alt wird überschrieben. Ich benötige jedoch beide Listen im Original. Dafür soll die neue dritte Liste die Werte aus den beiden anderen enthalten.
Gruß Mat
Anzeige
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

Anzeige
AW: Listen kombinieren
24.04.2010 22:09:54
Mat
Hallo Dirk,
ich bekomme Fehler (Syntax - Text ist Rot) bei
'Neue Liste zur Einarbeitung ueber Benutzerdialog auswaehlen
NeuDatei = Application.GetOpenFilename(sFilter, , Title:="Bitte neue Liste zur Einarbeitung _
auswaehlen", Buttontext:="Einarbeiten", MultiSelect:=False)
und
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)"
Gruß Mat
AW: Listen kombinieren
25.04.2010 08:25:00
Dirk
Hallo Mat,
der Fehler kommt durch die Formatierung der Makros in diesem Forum.
Ich mache mal die Zeilenumbrueche anders, damit Du das 1:1 kopieren kannst (ggf. die Zeichenfolge '& _' und den Anschliessenden Zeilenumbruch im Makro loeschen, falls es nicht funktionieren sollte.) :
Option Explicit
Public MyArray1(15)
Public MyArray2(15)
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
Lass' hoeren, ob ok.
Gruss
Dirk aus Dubai
Anzeige
AW: Listen kombinieren
25.04.2010 20:08:19
Mat
Hallo Dirk,
das Makro läuft jetzt ohne Fehler durch. Leider sind im Ergebnis noch einige Fehler:
In der neu erstellten Arbeitsmappe werden die geänderten Artikel zweimal gelistet. Einmal gelb markiert und einmal unmarkiert. Bei der unmarkierten Zeile hören die Werte bei Spalte O auf.
Viele Grüße
Mat

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige