Duplikate entfernen und Werte gleichzeitig sortier

Sub DuplikateEntfernen() Dim Zeile As Long ' Dim Zeilemax As Long 'SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With tbl_test3 With tbl_UAE01 ' Zeilemax = .UsedRange.Rows.Count For Zeile = 2 To 800 .Range("H2:H800").Copy Destination:=Worksheets("tbl_test3").Range("C1") Next Zeile End With .Range("C1:C800").RemoveDuplicates Columns:=1, Header:=xlNo .SortMethod = xlPinYin .Apply End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub Duplikate_raus() Dim loLetzte As Long Dim loLetzte1 As Long Application.ScreenUpdating = False With Sheets("tbl_UAE01") loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row .Range(.Cells(2, 2), .Cells(loLetzte, 2)).Copy _ Sheets("tbl_test3").Range("B1") End With With Sheets("tbl_test3") .Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo loLetzte1 = .Cells(.Rows.Count, 2).End(xlUp).Row .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("B1"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With With ActiveWorkbook.Worksheets("tbl_test3").Sort .SetRange Range("B1:B" & loLetzte1) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With With Sheets("tbl_test3") .Range("B1:B" & loLetzte1).Copy .Range("C2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True .Range("B1:B" & loLetzte1).ClearContents End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Public Sub Duplikate_raus() Dim loLetzte As Long Dim loLetzte1 As Long Dim letzteSpalte As Long Application.ScreenUpdating = False With Sheets("tbl_UAE01") loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row .Range(.Cells(2, 2), .Cells(loLetzte, 2)).Copy _ Sheets("tbl_test3").Range("B1") End With With Sheets("tbl_test3") .Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo loLetzte1 = .Cells(.Rows.Count, 2).End(xlUp).Row .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("B1"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal End With With ActiveWorkbook.Worksheets("tbl_test3").Sort .SetRange Range("B1:B" & loLetzte1) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With With Sheets("tbl_test3") .Range("B1:B" & loLetzte1).Copy .Range("C2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True letzteSpalte = .Cells(2, .Columns.Count).End(xlToLeft).Column .Range("C2").Copy .Range(.Cells(2, 4), .Cells(2, letzteSpalte)).PasteSpecial xlPasteFormats .Range("B1:B" & loLetzte1).ClearContents End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Hallo Werner,
ich muss mich leider nochmal bei dir melden. Ich schaffe es einfach nicht die Formel an meine neuen Bedinungen anzupassen. Dieses mal soll die Spalte für den Sortier und Duplikate entfernen Vorgang A sein, also gleich die erste und die Werte ab B1 beginnen. Simpel dachte ich aber ich verstehe Teile vom Code nicht.


Public Sub Duplikate_Material()
Dim loLetzte As Long
Dim loLetzte1 As Long
Dim letzteSpalte As Long
Application.ScreenUpdating = False
With tbl_UAE01 'Codename (Indexname außerhalb des gültigen Bereichs)
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row 'Anzahl der Zeilen in der ersten Spalte  _
der ersten Tabelle ermitteln
.Range(.Cells(2, 1), .Cells(loLetzte, 1)).Copy _
Sheets("tbl_MatrNr").Range("A1") 'Kopieren der Werte in Spalte 1 ab Zeile 2 und übertragen  _
in Zelle A1 in der zweiten Tabelle
End With
With tbl_MatrNr
'Zwischenspeicherung der Werte, Sortierung
'Spalte muss frei bleiben da ansonsten Werte überschrieben werden!!
.Range("A1:A").RemoveDuplicates Columns:=1, Header:=xlNo 'In der zwischenspalte A werden  _
die Duplikate entfernt
loLetzte1 = .Cells(.Rows.Count, 1).End(xlUp).Row 'Danach wird die neue Anzahl an Zeilen  _
ermittelt
.Sort.SortFields.Clear 'Vorsortierung löschen
.Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'Werte in der  _
zwischenspalte A sortieren
End With
With tbl_MatrNr.Sort '
.SetRange Range("A1:A" & loLetzte1) 'Sortieren mit der neuen Anzahl an Zeilen
.Header = xlNo 'Keine Headerformatierung
.MatchCase = False '?
.Orientation = xlTopToBottom 'Text orientierung
.Apply 'Sortierung anwenden
End With
With tbl_MatrNr
.Range("A1:A" & loLetzte1).Copy 'Kopieren mit neuen Bereich
.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True 'Einfügen der bearbeitenden Werte ab B1 in transponieren Form
letzteSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column 'Ermittlung der letzen  _
Spalte (Zeile 1, Ermittlung Spalte)
.Range("B1").Copy
.Range(.Cells(1, 2), .Cells(1, letzteSpalte)).PasteSpecial xlPasteFormats
.Range("A1:A" & loLetzte1).ClearContents
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Zum besseren Verständnis habe ich den Code so gut es geht kommentiert. Spätestens ab den letzten Block verstehe ich nicht ganz die Vorgehensweise
https://www.herber.de/bbs/user/112302.xlsx
Eine Beispiel Tabelle: A1 soll zum Zwischenspeichern des Codes sein und ab B1 die eindeutigen Werte aus der ersten Spalte in der tbl_UAE01.
Vielen lieben Dank für eure Unterstützung
Viele Grüße
Christian

Sub DuplikateEntfernen() ' Dim Zeile As Long ' Dim Zeilemax As Long ' With tbl_UAE01 ' Zeilemax = .UsedRange.Rows.Count ' For Zeile = 2 To 800 ThisWorkbook.Worksheets("tbl_UAE01").Range("H2:H800").Copy _ Destination:=Worksheets("tbl_test3").Range("C1") ' Next Zeile ' End With Worksheets("tbl_test3").Range("C1:C800").RemoveDuplicates _ Columns:=1, _ Header:=xlNo With ThisWorkbook.Worksheets("tbl_test3").Sort .SetRange Range("C1:C800") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub

Beliebteste Forumthreads (12 Monate)

Duplikate entfernen und Werte gleichzeitig sortier

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

71 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Duplikate entfernen und Werte gleichzeitig sortier

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

71 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread