AW: 2 Tabellen Verknüpfen
14.06.2017 20:53:40
Werner
Hallo Adem,
hier ein anderer Ansatz mit RemoveDuplicates.
Dazu wird während dem Makrolauf eine Nummerierung der Datensätze im Blatt "Alle" in Spalte U eingefügt (braucht man nur wegen der Sortierung und wird danach wieder entfernt).
Das setzt natürlich voraus, dass dort keine Daten vorhanden sind.
Wenn doch, dann müsste das Makro noch angepasst werden.
Dann aber bitte eine kleine Beispielmappe mit ggf. anonymisierten Beispieldaten.
Kannst ja mal testen.
Public Sub Aktualisieren()
Dim loArtikel As Long 'letzte Zeile Artikel
Dim loAlle As Long 'letzte Zeile Alle
loArtikel = Worksheets("Artikel").Cells(Rows.Count, 1).End(xlUp).Row
loAlle = Worksheets("Alle").Cells(Rows.Count, 1).End(xlUp).Row + 1
Application.ScreenUpdating = False
'alle Daten aus Blatt Artikel in Blatt Alle (unten)
With Worksheets("Artikel")
.Range(.Cells(2, 1), .Cells(loArtikel, 20)).Copy _
Worksheets("Alle").Cells(loAlle, 1)
End With
loAlle = Worksheets("Alle").Cells(Rows.Count, 1).End(xlUp).Row
'Datensätze in Spalte U durchnummerieren
With Worksheets("Alle")
.Range(.Cells(3, 21), .Cells(loAlle, 21)).FormulaLocal = "=ZEILE()-2"
.Range(.Cells(3, 21), .Cells(loAlle, 21)).Value = .Range(.Cells(3, 21), .Cells(loAlle, 21)). _
Value
End With
'Datensätze nach Spalte U absteigend sortieren
Worksheets("Alle").Sort.SortFields.Clear
Worksheets("Alle").Sort.SortFields.Add Key:=Range("U3:U" & loAlle), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With Worksheets("Alle").Sort
.SetRange Range("A3:U" & loAlle)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Worksheets("Alle").Columns("U:U").ClearContents 'Nummerierung in Spalte U löschen
'Duplicate (Kriterium in Spalte A) entfernen
Worksheets("Alle").Range("A3:T" & loAlle).RemoveDuplicates Columns:=1, Header:=xlNo
'Datensätze nach Spalte A aufsteigend sortieren
Worksheets("Alle").Sort.SortFields.Clear
Worksheets("Alle").Sort.SortFields.Add Key:=Range("A3:A" & loAlle), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets("Alle").Sort
.SetRange Range("A3:T" & loAlle)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Application.ScreenUpdating = True
End Sub
Gruß Werner