Dubbele regels

[Niels28]

Hallo,

Ik heb een bestandje gemaakt om mijn bankzaken bij te houden,
Ik kopieer de gegevens van de rabobank site (tabblad Rabobank) en
plak deze op het tabblad omzetten.
Laat dan een macro draaien die de gegevens verwerkt op tabblad jaar overzicht.

Hoe kan ik er voor zorgen dat er geen dubbele regels (kolom A: E) op het jaar overzicht komen te staan?


Niels

 

[RoCompy87]

Hallo,

Ik heb eens wat geprobeerd, maar ik kom er nog niet uit. Maar misschien biedt het jou of iemand anders inspiratie om iets te krijgen wat wél werkt .

Ik heb de sub 'omzetten' even herschreven in 'omzetten2' en ik heb daarbij geprobeerd met een autofilter te werken. Het idee is dat als na het filteren van de kolommen A:E er nog meer dan één record is, dan is het record dus dubbel en kan het weg. Maar de autofilter neemt het criterium nog niet goed over. Wie helpt?

 

[Gert Bouwmeeste]

Allereerst: je voorbeeldbestand bevat volgens mij "gevoelige" informatie. Die zou ik weghalen en vervangen door "niet-gevoelige" informatie.

Over je vraag: waarom gebruik je geen download van de Rabo. Aan de linkerkant in het menu kun je kiezen voor Download en daarna in welke format je wilt downloaden. Op de site van de Rabobank tref je een toelichting aan over de verschillende formaten. Ik gebruik zelf altijd "Vaste breedte", werkt prima en je hebt geen last van dubbele regels of rare layout.

 

[Niels28]

@RoCompy87

Dank je voor het aanpassen, heb weer wat bij geleerd daar jij mijn omwegen er uit hebt gehaald.
Helaas kan ik zelf niks met het filter gedeelte want ik begrijp niet hoe je daar de dubbele regels mee zichtbaar kunt maken.


@Gert Bouwmeeste
Dank je voor het meedenken, er staat geen gevoelige info in dit zijn fictieve bedragen.
Ik heb bewust niet gekozen voor een download omdat ik het makkelijker vind om gewoon te kopiëren en te plakken.

Niels

 

[Niels28]

Ik heb het opgelost met:

Sub omzetten2()
Dim r As Long, s As Long
Dim c As Range
plaatjes_verwijderen
Application.ScreenUpdating = False
With Sheets("omzetten")
    .Rows.UnMerge
    r = .Cells.Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row
    .Columns(3).ClearContents
    For s = r To 2 Step -1
        If Len(.Cells(s, 8)) = 0 Or Not IsNumeric(.Cells(s, 8)) Then
            .Rows(s).Delete
            Else
                .Cells(s, 3) = Month(.Cells(s, 2))
                .Cells(s, 8) = Right(.Cells(s, 8), Len(.Cells(s, 8)) - 1) * 1
                .Cells(s, 8).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
        End If
    Next s
    Union(.Columns(1), .Columns(4), .Columns(7)).EntireColumn.Delete
    r = .Cells.Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row
    s = Sheets("jaar overzicht").Columns(1).Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row
    .Range("A2:F" & r).Copy Destination:=Sheets("jaar overzicht").Cells(s + 1, 1)
    .Rows("2:" & r).Delete
    .[a1] = "Ctrl + O = data verwerken"
    .[d1] = "rekening overzicht plakken in A2"
End With
With Sheets("jaar overzicht")
    .Activate
    r = .Columns(14).Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row
        Range("M3:O" & r).Delete shift:=xlUp
        Set c = Range(Cells(1, 3), Cells(r, 3))
            For Each cl In c
            If InStr(c01, UCase(cl)) = 0 Then c01 = c01 & "|" & UCase(cl)
            Next
        Cells(2, 13).Resize(UBound(Split(c01, "|"))) = Application.Transpose(Split(Mid(c01, 2), "|"))
    r = .Columns(13).Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row
    Range(Cells(3, 14), Cells(r, 15)) = Sheets("rekenblad").Range("c4").Formula
    Cells(r + 1, 14) = Sheets("rekenblad").Range("c5").Formula
    Cells(r + 1, 15) = Sheets("rekenblad").Range("c6").Formula
    
    r2 = .Columns(1).Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row
    For x = 2 To r2
    Cells(x, 17) = Cells(x, 1) & Cells(x, 3) & Cells(x, 4) & Cells(x, 5)
    Cells(x, 18).FillDown            'in R1 staat formule =AANTAL.ALS(Q:Q;Q1)
    Next x
    
    For x = 2 To r2 Step 1
    If Cells(x, 18).Value > 1 Then
    .Cells(x, 1).Resize(, 5).Delete shift:=xlUp
    .Cells(x, 17).Resize(, 2).Delete shift:=xlUp
    x = x - 1
    End If
    Next x
    
.Range("q2:R" & r2).ClearContents
Application.ScreenUpdating = True
End With
End Sub

Dit werkt bij mijn originele bestand, maar in mijn voorbeeldbestand werkt het alleen als is stap voor stap de macro door loop met F8.

Waar ligt dit aan?

Niels

 

[RoCompy87]

Bij welke regel loopt de macro vast in het voorbeeldbestand?

 

[RaymondC]

Deze code ooit eens gevonden op het www:

DeleteDuplicateRows

This macro will delete duplicate rows in a range.* To use, select a single-column range of cells, comprising the range of rows from which duplicates are to be deleted, e.g., C2:C99.** To determine whether a row has duplicates, the values in the selected column are compared. Entire rows are not compared against one another.* Only the selected column is used for comparison.* When duplicate values are found in the active column, the first row remains, and all subsequent rows are deleted.

Public Sub DeleteDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
******************* ActiveSheet.Columns(ActiveCell.Column))

Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")

N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
*** Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If

V = Rng.Cells(R, 1).Value
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Note that COUNTIF works oddly with a Variant that is equal to vbNullString.
' Rather than pass in the variant, you need to pass in vbNullString explicitly.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If V = vbNullString Then
*** If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
******* Rng.Rows(R).EntireRow.Delete
******* N = N + 1
*** End If
Else
*** If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
******* Rng.Rows(R).EntireRow.Delete
******* N = N + 1
*** End If
End If
Next R

EndMacro:

Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)

End Sub

 

[Niels28]

@RoCompy87
Hij loopt niet vast,de macro loopt gewoon maar de dubbele regels blijven staan
behalve als ik hem met F8 door loop.

Ik denk dat het iets met de snelheid te maken heeft omdat het voorbleed bestand een stuk kleiner is.

Ik heb nu x=x-1 verandert in x=x-3 en dan doet hij het wel.

Bedankt voor het meedenken probleem is opgelost.

Niels

edit:
Simpele code gevonden voor >= office2007

voorbeeld:

    ActiveSheet.Range("$E$5:$I$7").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), _
        Header:=xlNo