Knoeien met arrays (deel 2)

[Peter B]

Goedemiddag!

Na de hulp (en de uitnodiging van snb) hierbij een vervolgvraag.

Even als achtergrond een stukje herhaling:
Voor een "eigen" projectje lees ik een bestand in en ga hier mee rommelen. O.b.v. bepaalde voorwaarden worden regels uit elkaar getrokken, samengevoegd, etc. Ik had dit werkend met het werken op een sheet, maar dit duurde vrij lang (1 minuut voor 200.000 regels). Dus overgestapt naar Arrays.

Wat wil ik bereiken. Ik wil dat waarden voorwaardelijk worden samengevoegd tot, in dit voorbeeld, "AA,BB,CC,DD,EE,FF,GG,HH" etc. Vandaar dat ik wat moeilijk goochel met een tweede array en twee tellers. Ik heb voor de duidelijkheid dat stuk code hier weggelaten (want dat is het issue niet).

snb wist mij al in de originele vraag uit te leggen dat de transpose de oorzaak was van mijn probleem (nl. vanaf regel 27454 ofzo alleen nog maar #NA).

Ik ben daarna aan het stoeien (of knoeien) gegaan met een code zonder transpose:

Sub arrayTest()

Dim arrIn, arrOut As Variant
Dim Rng As Range
Dim a, b As Long

    For a = 1 To 200
        ActiveSheet.Cells(a, 1).Value = "AA"
        ActiveSheet.Cells(a + 1, 1).Value = "B"
        ActiveSheet.Cells(a + 2, 1).Value = "B"
        ActiveSheet.Cells(a + 3, 1).Value = "CC"
        ActiveSheet.Cells(a + 4, 1).Value = "DDE"
        ActiveSheet.Cells(a + 5, 1).Value = "E"
        ActiveSheet.Cells(a + 6, 1).Value = "FF"
        ActiveSheet.Cells(a + 7, 1).Value = "G"
        ActiveSheet.Cells(a + 8, 1).Value = "GH"
        ActiveSheet.Cells(a + 9, 1).Value = "H"
        a = a + 9
    Next a

    Set Rng = ActiveSheet.Range("A1:A200")
    arrIn = Rng.Value
    b = 0
    
    For a = 1 To UBound(arrIn)
        If b = 0 Then
            ReDim arrOut(b)
        Else
            ReDim Preserve arrOut(b)
        End If
        arrOut(b) = arrIn(a, 1)
        b = b + 1
    Next a
    
    ActiveSheet.Range("C1").Resize(UBound(arrOut)).Value = arrOut

End Sub

Ik heb de code even zo gemaakt dat de cellen A1:A200 worden gevuld met voorbeeldwaarden. Kortom, de code is in een lege sheet te plakken en te runnen. Het issue wat ik nu heb is dat ik of in kolom C alleen maar "AA" krijg tot regel 200 of in rij 1 de correcte waarden door de laatste regel aan te passen naar "ActiveSheet.Range("C1").Resize(1, UBound(arrOut)).Value = arrOut" ...

 

[snb]

En nu nog een voorbeeldbestand.....

 

[Peter B]

Sorry. Ik zit op m'n werk pc en wil daar vandaan geen bestanden uploaden. Vandaar dat ik meende dat een code waarbij alle data gegenereerd werd wel een optie zou zijn.

Ik ben intussen verder gaan "knoeien" en heb een oplossing gevonden door 1) de arrOut vast te definiëren en 2) de ReDim Preserve er uit te slopen. Hierin definieer dat arrOut is net zo groot als arrIn om de optimale snelheid te houden en omdat ik weet dat arrIn altijd groter zal zijn dan arrOut.

Zie de volgende code:

Sub arrayTest()

Dim arrIn, arrOut As Variant
Dim a, b, max As Long

    For a = 1 To 200000
        ActiveSheet.Cells(a, 1).Value = "AA"
        ActiveSheet.Cells(a + 1, 1).Value = "B"
        ActiveSheet.Cells(a + 2, 1).Value = "B"
        ActiveSheet.Cells(a + 3, 1).Value = "CC"
        ActiveSheet.Cells(a + 4, 1).Value = "DDE"
        ActiveSheet.Cells(a + 5, 1).Value = "E"
        ActiveSheet.Cells(a + 6, 1).Value = "FF"
        ActiveSheet.Cells(a + 7, 1).Value = "G"
        ActiveSheet.Cells(a + 8, 1).Value = "GH"
        ActiveSheet.Cells(a + 9, 1).Value = "H"
        a = a + 9
    Next a

    b = 1
    max = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    arrIn = ActiveSheet.Range("A1:A" & max).Value
    ReDim arrOut(1 To max, 1 To 1)
    
    For a = 1 To UBound(arrIn)
        If a > 1 Then
            If Right(arrIn(a - 1, 1), 1) = Left(arrIn(a, 1), 1) Then
                arrOut(b - 1, 1) = Right(arrIn(a - 1, 1), 1) & Left(arrIn(a, 1), 1)
                arrIn(a, 1) = Right(arrIn(a, 1), Len(arrIn(a, 1)) - 1)
                b = b - 1
            Else
                arrOut(b, 1) = arrIn(a, 1)
            End If
        Else
            arrOut(b, 1) = arrIn(a, 1)
        End If
        b = b + 1
    Next a
    
    ActiveSheet.Range("C1").Resize(UBound(arrOut)).Value = arrOut

End Sub

Het genereren van de testdata duurt verreweg het langst.

Dank voor je handige website!