VBA morko doppelte Zeileneinträge löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Doppelte_Löschen() Dim Ze1 As Long, Ze2 As Long Ze1 = 8 Ze2 = Cells(Rows.Count, 1).End(xlUp).Row With Range(Cells(Ze1, 1), Cells(Ze2, 1)).EntireRow .Sort key1:=Cells(8, "A"), order1:=xlAscending, _ key2:=Cells(8, "C"), order2:=xlAscending, _ key3:=Cells(8, "F"), order3:=xlAscending, header:=xlNo End With Columns(1).Insert With Range(Cells(Ze1, 1), Cells(Ze2, 1)) .FormulaR1C1 = "=IF(AND(RC[1]=R[-1]C[1],RC[3]=R[-1]C[3],RC[6]=R[-1]C[6]),TRUE,ROW())" .Formula = .Value .EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete End With Columns(1).Delete End Sub

Hallo,
nett daß Du mir so schnell geantwortet hast. Aber leider funktioniert das Makro - auch wenn ich es umschreibe nicht.
Deshalb anbei den Tabelleninhalt (Muster) als Text.
-----------------------------------------
hier stehen noch andere Daten die nicht verändert werden sollen;;;;;;;;;
hier stehen noch andere Daten die nicht verändert werden sollen;;;;;;;;;
hier stehen noch andere Daten die nicht verändert werden sollen;;;;;;;;;
hier stehen noch andere Daten die nicht verändert werden sollen;;;;;;;;;
hier stehen noch andere Daten die nicht verändert werden sollen;;;;;;;;;
hier stehen noch andere Daten die nicht verändert werden sollen;;;;;;;;;
Gruppe#;Familienname#;Akademischer Grad#;Vorname(n)#;Geburtsdatum#;Familienstand#;Telefon#;Beruf#;Anschrift#;Übungsleiter#
LG;Armadi;;Guido;;;;;52249 Kranken Albin-K?Isstrasse 12;
TW;Ronaldo;;Stefanie;;;;;76348 Rauchbronn Ulmenweg 3;
TT;Armadi;;Ester;;;;;52249 Kranken Albin-K?Isstrasse 12;
FB;Grauer;;Manjola;;;;;76530 Baden-Baden Oostalstrasse 11;
TW;Lekitic;;Josefine;;;;;74074 Heimsheim Friedrich-Dengler-Strasse 55;
LG;Armadi;;Guido;;;;;52249 Kranken Albin-K?Isstrasse 12;
----------------------------------------------
Die ersten 6 Zeilen der Tabelle können nicht verändert werden.
Vielleicht hat jemand eine Idee wie ich die Doppelte Zeile löschen kann. Mit einer Formel in meiner Tabelle kann ich nichts anfangen.
Bernhard

Sub Löschedoppelt() Dim SuchBer As Range, SuchAddress As String Dim Tabel As Worksheet, Tabelneu As Worksheet Application.ScreenUpdating = False Set Tabel = ActiveSheet With Tabel Set SuchBer = _ .Range(.Cells(6, 1), .Cells(Rows.Count, 1).End(xlUp).Offset(0, Columns.Count - 1)) End With SuchAddress = SuchBer.Address Set Tabelneu = Sheets.Add SuchBer.AdvancedFilter _ Action:=xlFilterCopy, CopyToRange:=Tabelneu.Range("A7"), Unique:=True SuchBer.ClearContents Tabelneu.Range(SuchAddress).Copy Tabel.Range(SuchAddress) With Application .DisplayAlerts = False Tabelneu.Delete .DisplayAlerts = True .ScreenUpdating = True End With Set Tabel = Nothing Set Tabelneu = Nothing Set SuchBer = Nothing End Sub

HAllo Bernhard
Wenn du in dem relevanten Bereich keine Formeln hast, versuch mal dies:

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Public Sub test()
Dim b As Range 'Der interessante Bereich
Dim Dic 'Dictionary
Dim L 'Zeilenzähler
Dim I 'Dir Items des Dictionarys
Dim J As String 'Verkettung der jeweiligen Einträge
Set Dic = CreateObject("Scripting.dictionary")
Set b = Intersect(Range("A1").CurrentRegion, Range("A7:J65536"))
For L = 1 To b.Rows.Count
    J = Join(Array(b(L, 2), b(L, 4), b(L, 9)), "###")
    Dic(J) = b.Rows(L)
Next
I = Dic.items
'Bereich löschen
b.ClearContents
'Unikate eintragen
For L = 1 To Dic.Count
    b.Rows(L) = I(L - 1)
Next
End Sub

ransi

Sub testA() Dim vntSpalten() Dim lngZeile As Long, intZähler As Integer, x As Long vntSpalten = Array("B", "D", "I") 'Prüfspalten ggf. anpassen !! For lngZeile = Cells(Rows.Count, 1).End(xlUp).Row To 8 Step -1 x = 1 For intZähler = LBound(vntSpalten) To UBound(vntSpalten) x = x * Application.WorksheetFunction.CountIf _ (Range(Cells(7, vntSpalten(intZähler)), _ Cells(lngZeile - 1, vntSpalten(intZähler))), _ Cells(lngZeile, vntSpalten(intZähler))) Next If x > 0 Then Rows(lngZeile).Delete Next End Sub

Sub Groessentest() 'Test, wie groß der Datenbereich ist und wandelt GROSS in Gross um XYTab = ActiveWorkbook.Name ActiveCell.SpecialCells(xlLastCell).Select y = ActiveCell.Row z = ActiveCell.Column Dim n As Variant For n = 1 To y Cells(n, 1).Activate Name = ActiveCell.Value If ActiveCell "" Then Cells(n, 1) = Application.WorksheetFunction.Proper(Cells(n, 1)) End If Next n End Sub

Sub Groessentest() 'Test, wie groß der Datenbereich ist und wandelt GROSS in Gross um XYTab = ActiveWorkbook.Name ActiveCell.SpecialCells(xlLastCell).Select Y = ActiveCell.Row z = ActiveCell.Column 'was folgt stellt nur um auf Gross/Kleinschreibung (war halt noch drin) Dim N As Variant For N = 1 To Y Cells(N, 1).Activate Name = ActiveCell.Value If ActiveCell "" Then Cells(N, 1) = Application.WorksheetFunction.Proper(Cells(N, 1)) End If Next N End Sub

Beliebteste Forumthreads (12 Monate)

VBA morko doppelte Zeileneinträge löschen

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA morko doppelte Zeileneinträge löschen

22 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread