Sorteren blokken rijen.

[fwalraven]

Het commentaar "''Verwijder eventuele punten, komma,s enof spaties." klopt niet, alleen punten worden verwijderd. En beide regels code doen precies hetzelfde:

Sheets("Gesorteerd").Range("A1").Resize(UBound(a), 6) = b
Sheets("Gesorteerd").Range("A1").Resize(UBound(b, 1), UBound(b, 2)) = b

En je vertelt niet welke foutmelding je krijgt.

Inderdaad, beide regels doen het nu wel goed.????

Wat de foutmelding was, weet ik niet meer.
Ik vermoed: Compileerfout, een variabele is niet gedefinieerd.
Maar dat is echt een gok.
Ik weet alleen dat die regel geel gearceerd was.

Via de vraag aan DeepSeek, wat is er fout aan: Sheets("Gesorteerd").Range("A1").Resize(UBound(a), 6) = b
Kreeg ik meerdere mogelijkheden die de oorzaak konden zijn, oa: Sheets("Gesorteerd").Range("A1").Resize(UBound(b, 1), UBound(b, 2)) = b[

Na die regel aangepast te hebben ging het wel goed.

 

[fwalraven]

Beetje meer snelheid in de code kan geen kwaad.

Heb er twee codes in staan.
De eerste schrijft per blok weg en is daarmee iets sneller, maar geen test op snelheid met meerdere blokken.
Het blad 'Sorteer' is hierbij niet nodig.

HSV,
Ik waardeer het zeer zeker dat u mee denkt aan een oplossing.
Maar ik blijf bij de oplossing van AHulpje.
Frans

 

[AHulpje]

@HSV
Ik denk dat TS daar heel blij mee is, 0,0078 sec in plaats van 0,0234 sec.! Dan kan hij de macro 128 keer per seconde uitvoeren i.p.v. slechts 42 keer.

 

[HSV]

@AHulpje ,
Het is meer iets ter lering van denk ik zo (ook voor jou) i.p.v. ChatGPT te raadplegen.
Inlezen en wegschrijven in een array.

 

[AHulpje]

@HSV
Er is geen letter ChatGPT aan te pas gekomen en ik was er echt van overtuigd dat a en b in mijn code array's waren. Maar ik moet wel zeggen dat jouw code zeker niet verkeerd is.

 

[HSV]

Ik heb je wel iets betere codes zien schrijven toch?
Onderstaand stuk code wordt niet weggeschreven als array en de sorteermethode lijkt mij niet echt het werk van jou.

With Sheets("Sorteer")
        .Cells(r, 1) = a(1, 1)
        .Cells(r, 2) = a(1, 2)
        .Cells(r, 3) = 1
        For i = 1 To UBound(a)
            If a(i, 1) = "" Then
                r = r + 1
                .Cells(r, 1) = a(i + 1, 1)
                .Cells(r, 2) = a(i + 1, 2)
                .Cells(r, 3) = i + 1
                .Cells(r - 1, 4) = i - 1
            End If
        Next
        .Cells(r, 4) = i - 1
        With .Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range("A:A")
            .SortFields.Add2 Key:=Range("B:B")
            .SetRange Range("A:D")
            .Apply
        End With
        j = -1