|
Hallo
versuch das mal.
Sub Gleiche_weg()
On Error GoTo Fehler
Dim TB As Worksheet
Dim Sp As Integer, LR As Long, LC As Integer
Const APPNAME = "Gleiche_weg"
'*** bescheunigt das Makro
Application.ScreenUpdating = False
'*** Stammdaten Anfang
Set TB = Sheets("Tabelle1")
Sp = 1 'Spalte A
'*** Stammdaten Ende
With TB
'möglichen Autofilter ausschalten
If .AutoFilterMode Then .AutoFilterMode = False
LR = .Cells(.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile
'Temporäre Spalten / Formeln
.Cells(1, LC + 2) = "Temp"
.Cells(1, LC + 3) = "Anzahl"
.Cells(2, LC + 2).Resize(LR - 1, 1).FormulaR1C1 = "=RC[-4]&""|""&RC[-3]"
.Cells(2, LC + 3).Resize(LR - 1, 1).FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
'Filtern
.Columns(LC + 3).AutoFilter Field:=1, Criteria1:=">1"
'gefilterte Zeilen löschen
.Cells(1, 1).CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilterMode = False
'temporäte Spalten weg
.Columns(LC + 2).Resize(, 2).Delete
End With
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD
|