Dubbele rijen verwijderen

[robert123321]

Hallo,

Ik probeer met een macro de dubbele rijen te verwijderen. Zo lang ik de macro stap voor stap door loop gaat alles goed. Echter wanneer ik de macro zelf laat runnen crashed excel :shocked:

Er is vast een veel effectievere en betere manier om deze opdracht uit te voeren.
Wat ik wil is dat wanneer er duplicaten worden gevonden dat deze gehele rijen verwijderd worden. Per rij moet kolom A t/m L dus vergeleken worden met de overige rijen (ook A t/m L). Wanneer er een duplicaat wordt gevonden, maar deze een waarde heeft staan in kolom M dan moet deze niet verwijderd worden.
Het klinkt simpel maar het heeft even geduurd voor ik het voor elkaar kreeg en dus helaas alleen als ik het stap voor stap doe.

Dim cRow As Integer
    Dim cRow2 As Integer
    Dim cCol As Integer
    Dim foundDuplicate As Boolean

    cRow = 2
    Do While IsEmpty(Worksheets("Verstreken").Cells(cRow, 1)) = False
        cRow2 = cRow + 1
        Do While IsEmpty(Worksheets("Verstreken").Cells(cRow2, 1)) = False
            foundDuplicate = True
            For cCol = 1 To 12
                If Worksheets("Verstreken").Cells(cRow, cCol).Value <> Worksheets("Verstreken").Cells(cRow2, cCol).Value Then
                    foundDuplicate = False
                    Exit For
                End If
            Next
            If foundDuplicate = True Then
                Rows(cRow2).Select
                    If Selection.Columns("M") = "" Then
                Worksheets("Verstreken").Rows(cRow2).Delete xlShiftUp
            Else
                cRow2 = cRow2 + 1
            End If
            
            End If
        Loop
        cRow = cRow + 1
    Loop

 

[snb]

Sub ontdubbel()
  With sheets("verstreken")
    sq=.Cells(1, 1).currentregion
    for j= 1 to ubound(sq)-1
      for jj=1 to 12
        c0=c0 & sq(jj,jj)
        c1=c1 & sq(j+1,jj)
      next
      if c0=c1 and sq(j,jj)="" then sq(j,1)=""
    Next
    .Cells(1, 1).currentregion=sq
    .Columns(1).specialcells(xlcelltypeblanks).entirerow.delete
  End With
End Sub

 

[Cobbe]

Als je rijen wil verwijderen moet je van onder naar boven werken.
Anders klopt de telling natuurlijk niet meer.

Cobbe

 

[snb]

Of de methode toepassen uit mijn suggestie.

 

[Cobbe]

Of de methode toepassen uit mijn suggestie.

Dat kan natuurlijk ook maar dan moet je al van goede huize komen.

Cobbe

 

[robert123321]

Het subscript valt buiten bereik

Wanneer ik deze code probeer krijg ik een foutmelding: Het subscript valt buiten bereik
In rood waar die blijft hangen.

Sub ontdubbel()
  With sheets("verstreken")
    sq=.Cells(1, 1).currentregion
    for j= 1 to ubound(sq)-1
      for jj=1 to 12
       [COLOR="Red"] c0=c0 & sq(jj,jj)[/COLOR]
        c1=c1 & sq(j+1,jj)
      next
      if c0=c1 and sq(j,jj)="" then sq(j,1)=""
    Next
    .Cells(1, 1).currentregion=sq
    .Columns(1).specialcells(xlcelltypeblanks).entirerow.delete
  End With
End Sub

 

[Warme bakkertje]

Zo doet hij het mi wel

Sub ontdubbel()
  With Sheets("verstreken")
    sq = .Cells(1, 1).CurrentRegion
    For j = 1 To UBound(sq) - 1
      For jj = 1 To 12
        c0 = c0 & sq(j, jj)
        c1 = c1 & sq(j + 1, jj)
      Next
    If c0 = c1 And sq(j, jj) = "" Then sq(j, 1) = ""
    c0 = ""
    c1 = ""
    Next
    .Cells(1, 1).CurrentRegion = sq
    .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  End With
End Sub

 

[robert123321]

Zo doet hij het mi wel]

Beetje late reactie, maar bij mij werkt het niet. De foutmelding is weg maar de dubbele rijen worden niet verwijderd.
Wanneer er geen dubbele rijen zijn dan geeft die een foutmelding omdat er geen CellTypeBlanks aanwezig zijn. Dit kan ik wel oplossen door de code On error Resume Next toe te passen

 

[robert123321]

Opgelost!

Ik ben er al uit. Voor mijn macro heb ik een nu een ander stuk code gebruikt wat beter past bij de rest van de macro. Deze code ook gevonden hier ergens op het forum. Ahof bedankt!
Een kleine aanpassing (rij -1) ipv (rij +1) en de code sluit precies aan bij mijn macro

Hier de uiteindelijk door mij gebruikte code:

'Dim Rij, Kolom, StartRij, EindRij, TempValue
Application.Calculation = xlManual

On Error Resume Next
rij = ActiveCell.Row
kolom = ActiveCell.Column
Do While Cells(rij, kolom) <> ""
If Trim(Cells(rij, kolom).Value) = Trim(Cells(rij - 1, kolom)) Then
Rows(rij).Select
Selection.Delete Shift:=xlUp
Else
rij = rij + 1
End If
Loop
Cells(1, kolom).Select

Application.Calculation = xlAutomatic

@ warm bakkertje: Toch bedankt voor de moeite!

 

[Warme bakkertje]

En wat doe je met de voorwaarde uit je eerste post?

 

[robert123321]

Ik had niet alle aanpassingen vermeld. Bij deze:

Application.Calculation = xlManual

With Sheets("Verstreken")
    On Error Resume Next
    For Each cl In Range("K2:K" & Cells(Rows.Count, 11).End(xlUp).Row)
[B][COLOR="Red"]        If cl.Offset(, 2).Value = "" Then
            cl.Cells.Select[/COLOR][/B]
            Rij = ActiveCell.Row
            Kolom = ActiveCell.Column
                Do While Cells(Rij, Kolom) <> ""
                    If Trim(Cells(Rij, Kolom).Value) = Trim(Cells(Rij - 1, Kolom)) Then
                        Rows(Rij).Select
                        Selection.Delete Shift:=xlUp
                    Else
                        Rij = Rij + 1
                    End If
                Loop
            Cells(1, Kolom).Select
        End If
    Next
End With

Application.Calculation = xlAutomatic