doppelte Zeilen von unten löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub loeschen() Dim iZeile As Long Dim iSpalte As Byte Dim bCheck As Boolean For iZeile = Range("A65536").End(xlUp).Row To 1 Step -1 bCheck = False For iSpalte = 1 To 25 If Cells(iZeile, iSpalte) Cells(iZeile, iSpalte + 1) Or Cells(iZeile, iSpalte) = "" _ Then bCheck = True Exit For End If Next iSpalte If Not bCheck Then Rows(iZeile).Delete Next iZeile End Sub

Sub Loeschen_Mit_Formel() Dim oSH As Worksheet, iCalc As Integer Dim sFormel$, i As Integer Dim MaxCol As Long, MinCol As Long Set oSH = Sheets("Tabelle2") 'Tabelle anpassen With Application iCalc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False With oSH.UsedRange MinCol = .Cells(1, 1).Column With .Columns(.Columns.Count).Offset(0, 1) MaxCol = .Column - 1 MaxCol = Application.WorksheetFunction.Min(26, MaxCol) For i = MinCol To MaxCol sFormel = sFormel & "RC" & i & "&" Next i sFormel = "=" & Left$(sFormel, Len(sFormel) - 1) .FormulaR1C1 = sFormel 'entsprechende Formel .Offset(0, 1).FormulaR1C1 = _ "=IF((COUNTIF(R" & .Cells(1, 1).Row & "C[-1]:RC[-1],RC[-1])>1)*(RC[-1]<>""""),TRUE,ROW())" 'sortieren, Tabelle ist mit Überschrift oSH.UsedRange.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes On Error Resume Next .Offset(0, 1).SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete .Offset(0, 1).EntireColumn.Delete .EntireColumn.Delete On Error GoTo 0 End With End With .ScreenUpdating = True .Calculation = iCalc End With End Sub

Hallo,
so funktioniert es besser.

Sub Loeschen_Mit_Formel()
Dim oSH As Worksheet, iCalc As Integer
Dim sFormel$, i As Integer
Dim MaxCol As Long, MinCol As Long
Dim sLeer As String

Set oSH = Sheets("Tabelle1") 'Tabelle anpassen 

With Application
 iCalc = .Calculation
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 
  
     With oSH.UsedRange
        MinCol = .Cells(1, 1).Column
        With .Columns(.Columns.Count).Offset(0, 1)
             MaxCol = .Column - 1
             MaxCol = Application.WorksheetFunction.Min(26, MaxCol)
             
             For i = MinCol To MaxCol
                sFormel = sFormel & "IF(RC" & i & "="""",""|"",RC" & i & ")&"
             Next i
             sFormel = "=" & Left$(sFormel, Len(sFormel) - 1)
             sLeer = String(MaxCol - MinCol + 1, "|")
  
            .FormulaR1C1 = sFormel
            'entsprechende Formel 
            .Offset(0, 1).FormulaR1C1 = _
                "=IF((COUNTIF(R" & .Cells(1, 1).Row & "C[-1]:RC[-1],RC[-1])>1)*(RC[-1]<>""" & sLeer & """),TRUE,ROW())"
            
            'sortieren, Tabelle ist mit Überschrift 
            oSH.UsedRange.Sort Key1:=.Offset(0, 1).Cells(1, 1), Order1:=xlAscending, Header:=xlYes
            
            On Error Resume Next
            .Offset(0, 1).SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
            .Offset(0, 1).EntireColumn.Delete
            .EntireColumn.Delete
            On Error GoTo 0
        
        End With
     End With
 
 .ScreenUpdating = True
 .Calculation = iCalc
End With

End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

doppelte Zeilen von unten löschen

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

doppelte Zeilen von unten löschen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread