Sorteren met behulp van Macro

[koosl]

zie sheet "moet nog gesorteerd worden"

De gegevens moeten zo gesorteerd worden dat uiteindelijk 1 rij per winkelnr overblijft. (zie
formule rij G).
Kolom d moet vervolgens zo gesorteerd worden dat volgende volgorde gehanteerd wordt:
xx6, xx4, xx8, xx7

Ik hoop dat het een beetje duidelijk is. Maar misschien lukt het toch wel als je naar het voorbeeld kijkt in "zoals het gesorteerd moet zijn"


Koosl

 

[Wigi]

Wat is nu eigenlijk het nut van kolom G?

 

[koosl]

WiGi,

sorry dat het zo lang geduurd heeft, maar ik had even andere bezigheden.

De kolom G was om 1 regel (van de 3 of 4 regels van een en dezelfde winkel) over te houden waar ik op kon filteren. Deze kreeg namelijk een 1 mee door de formule. De dubbele kregen een 0. Maar ik liep vast op de sorteervolgorde.
In het voorbeeld had ik beter de kolom G weg kunnen gooien, dat was niet zo verwarrend geweest.

(Dit komt uit een database en bestaat uit wel 16000 regels)

Ik heb nog e.e.a. uitgelegd in de gewijzigde bijlage.


Koosl.

 

[Wigi]

Is dit het?

Sub Sortering6487()
    Range("A2", Range("A2").End(xlToRight).End(xlDown)).Copy _
        Sheets("zoals het gesorteerd moet zijn").Range("A2")
    With Sheets("zoals het gesorteerd moet zijn")
        .Range(.Range("A2").End(xlToRight), .Range("A2").End(xlToRight).End(xlDown)).Offset(, 1) _
            .FormulaR1C1 = "=LOOKUP(VALUE(RIGHT(RC[-3])),{4;6;7;8},{2;1;4;3})"
        .Range(.Range("A2"), .Range("A2").End(xlToRight).End(xlDown)).Sort _
            Key1:=.Range("B2"), Order1:=xlAscending, Key2:=.Range("A2").End(xlToRight), _
            Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False
        .Range(.Range("A2").End(xlToRight), .Range("A2").End(xlToRight).End(xlDown)).ClearContents
    End With
End Sub

Wigi

 

[koosl]

Wigi,

Bijna!

De sortering ziet er prima uit. Maar de dubbele rijen moeten nog verwijdert worden.
(In de nieuwe bijlage heb ik deze rood gemaakt.)

Die rode dubbelen hebben hetzelfde winkelnummer als van de bovenliggende zwarte rij.

Dus in dit voorbeeld heb je dan nog maar 6 rijen over.



Koosl

 

[Wigi]

Voor het eerste bestand werkt dit. Het tweede heb ik niet bekeken.

De code lijkt (én is) uitgebreider dan nodig, maar veel heeft te maken met het feit dat de code nu werkt voor een bereik van onbekende grootte.

Sub Sortering6487()
Dim lngRow As Long, i As Long
    Range("A2", Range("A2").End(xlToRight).End(xlDown)).Copy _
        Sheets("zoals het gesorteerd moet zijn").Range("A2")
    With Sheets("zoals het gesorteerd moet zijn")
        .Range(.Range("A2").End(xlToRight), .Range("A2").End(xlToRight).End(xlDown)).Offset(, 1) _
            .FormulaR1C1 = "=LOOKUP(VALUE(RIGHT(RC[-3])),{4;6;7;8},{2;1;4;3})"
        .Range(.Range("A2"), .Range("A2").End(xlToRight).End(xlDown)).Sort _
            Key1:=.Range("B2"), Order1:=xlAscending, Key2:=.Range("A2").End(xlToRight), _
            Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False
    lngRow = .Range("A2").End(xlDown).Row
    For i = lngRow To 3 Step -1
        If .Range("C" & i) = .Range("C" & i - 1) Then .Rows(i).Delete
    Next
        .Range(.Range("A2").End(xlToRight), .Range("A2").End(xlToRight).End(xlDown)).ClearContents
    End With
End Sub

Wigi

 

[koosl]

Knap Wigi! :thumb: En dat met zo'n korte code.

Het lijkt goed te werken. Ik zal het wel eerst wat uitvoeriger moeten testen met het grote bestand. ( met een kopietje )



Zou je misschien globaal uit kunnen leggen wat er gebeurt?


Koosl

 

[Wigi]

Gebruik F8 om door de macro te stappen en te zien wat er gebeurt.

Ook:

End(xlToRight) is het equivalent van Ctrl-pijltjerechts: ga naar meest rechtse cel

End(xlDown) is het equivalent van Ctrl-pijltjenaarbeneden: ga naar onderste cel

copy is copy natuurlijk

FormulaR1C1 zet een formule in de cellen

sort is sorteren natuurlijk

delete is delete natuurlijk

clearcontents wist de celinhoud

Wigi

 

[koosl]

Wigi,

Ik heb je code uitvoerig getest en het werkt prima! :thumb:

Nu durf ik het wel aan om het toe te passen op het officiele bestand.


Nog heel veel dank voor je code en uitleg.


Koosl

 

[Wigi]

Wigi,

Ik heb je code uitvoerig getest en het werkt prima! :thumb:

Nu durf ik het wel aan om het toe te passen op het officiele bestand.

Nog heel veel dank voor je code en uitleg.

Koosl

Wel, nu kan ik dan terug rustig slapen 's nachts Nee grapje natuurlijk.

Blij dat het werkt Koos.

Wigi