For...next lus om data in kolom A te converteren naar tabel

[RoVo1211]

Gegeven de bovenstaande tabel. De cellen A1:A10 zijn de veldnamen en deze heb ik al getransponeerd naar de cellen B1:K1.
In de cellen A11:A20, A21:A30 enz. staan de data die in de tabel moeten komen. Zo moet A11->B2, A12->C2 enz. zie bovenstaand voorbeeld. De gekleurde cellen geven het begin van een record aan.

Ik was al begonnen met een for...next-lus, maar ik kom er niet uit hoe ik in een for...next-lus bij de rijen 11, 21, 31 enz. kan komen.
Dat blijft een probleem voor mij.

Dit had ik reeds geschreven, maar dat werkt niet:

'Option Explicit
Sub Transponeren()
'
' Transponeren Macro
'

'
    Range("A1:A10").Select
    Selection.Copy
    Range("B1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    'Range("A1:A10").ClearContents
  
j = i + 9
k = j + 10
For i = 1 + j + 1 To i * 10 + i Step 10
'    Debug.Print "i: " & i, "i*10+i: " & i * 10 + i, "j: " & j, "k: " & k
    Range("A" & i & ":A" & j).Select 'hier moeten de records geselecteerd worden (A11:A20. A21:A30, enz.)
    i = i + 10
    k = k + 1
Next i
'    Columns("B:K").Select
'    Columns("B:K").EntireColumn.AutoFit
End Sub

Waar maak ik de fout?

Dit heb ik met de hand gedaan, maar zo moet het eruit komen te zien:

 

[AHulpje]

Zo (wel even Blad2 toevoegen):

Sub Transponeren()
    arr = Sheets("Blad1").UsedRange
    aantal = (UBound(arr) - 1) / 10
    With Sheets("Blad2")
        For i = 0 To aantal
            For k = 1 To 10
                r = i * 10 + k
                .Cells(i + 1, k) = arr(r, 1)
            Next
        Next
        .Activate
    End With
End Sub

 

[RoVo1211]

Super bedankt Ahulpje

 

[JEC.]

Hier is hij dan nog maar een keer

=WRAPROWS(A1:A130;10)

of in NL:

=OMLOOP.RIJEN(A1:A130;10)

 

[AHulpje]

Hm, toch maar eens overstappen op Office 365.

 

[RoVo1211]

@AHulpje : welke versie gebruik jij dan? Ik was iets te voorbarig, want jou macro vergat het laatste record. Ik ben wel bezig geweest waar ik "-1" moest weghalen om ook het laatste record mee te laten nemen.

@JEC. : Ik wist niet eens dat deze functie bestond. Is deze functie ook te gebruiken in VBA? Met worksheetfunction kan ik deze niet vinden. En Wraprows werkt ook niet.

 

[Warme bakkertje]

Hoe gaat deze dan?

Sub Transponeren()
    Dim res()
    With Sheets("Blad1")
        arr = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
    End With
    aantal = (UBound(arr)) / 10
    ReDim res(1 To aantal, 1 To 10): r = 1
    For i = 1 To aantal
        For k = 1 To 10
            res(i, k) = arr(r, 1): r = r + 1
        Next
    Next
    With Sheets("Blad2")
        .Cells(1).CurrentRegion.ClearContents
        .Cells(1).Resize(UBound(res), UBound(res, 2)) = res
        Application.Goto .Range("A1")
    End With
End Sub

 

[AHulpje]

Ik gebruik Office Professional Plus 2021, en die -1 had ik al verwijderd in bericht #2, jij was alleen iets te snel met kopiëren ;-).
De functie OMLOOP.RIJEN is beschikbaar vanaf Office 365 en die kun je gewoon in een cel als werkbladfunctie gebruiken, dat hoeft niet via VBA.

 

[RoVo1211]

Ik wilde deze functie graag in een macro zetten omdat het aantal rijen variabel is.
Het aantal rijen heb ik opgevraagd met

Dim Data As Range
Set Data = Sheets(1).Range("A1", Range("A250").End(xlUp))
Debug.Print Data.Address

In het voorbeeld dat ik jou had gestuurd stonden 12 records, in een ander bestand staan maar 8 records.
In "Forward Loads" was de range A1:A130; in "Reverse Loads" was de range A1:A90.

 

[Warme bakkertje]

Kan het zelf niet testen maar werkt dit in O365?

=OMLOOP.RIJEN(INDIRECT("$A$1:$A$" & AANTALARG($A:$A));10)

of

=WRAPROWS(INDIRECT("$A$1:$A$" & COUNTA($A:$A));10)

 

[RoVo1211]

Ik heb goed nieuws voor je: deze functie werkt op deze manier in Office 365

Ook jouw macro uit #7 werkt perfect. Deze neemt alle records mee.

 

[Warme bakkertje]

Bedankt voor het proberen.

Heb je ook de code geprobeerd die ik in Post#7 heb gezet?

 

[RoVo1211]

Ik gebruik Office Professional Plus 2021, en die -1 had ik al verwijderd in bericht #2, jij was alleen iets te snel met kopiëren ;-).

Ik heb de aangepaste versie gekopieerd en deze neemt idd alle records mee. Nogmaals dank.

 

[RoVo1211]

@Warme bakkertje : zie #11. Ik was bezig met het typen van het bericht, toen kwamen er al weer nieuwe berichten binnen en ben ik vergeten mijn bericht te plaatsen. Zowel de gewijzigde versie van AHulpje als jouw versie werken perfect. Bedankt beiden.

Ik denk dat ik deze vraag als opgelost kan markeren. Bij dezen.

 

[RoVo1211]

@Warme bakkertje :Volgens mij had je nog een bericht geplaatst, maar ik kan het nergens vinden.

 

[Warme bakkertje]

Heb er slechts 3 geplaatst, #7 - #10 - #12.

Heb enkel deze even later nog gewijzigd in #7

arr = Sheets("Blad1").UsedRange

naar

With Sheets("Blad1")
        arr = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
    End With

maar dat was het dan.

In ieder geval bedankt en suc6 verder met je project.

 

[snb]

Ook hier het principe:

1 keer lezen, 1 keer schrijven, bewerken in het werkgeheugen
Zo hoef je nooit iets in te stellen voor screenrefreshing of calculation.
Het aantal variabelen blijft dan ook tot een minimum beperkt.

Sub M_snb()
  sn = Application.Transpose(UsedRange.Columns(1))                       '   lezen
 
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn) Step 10                                                       '   bewerken
      .Item(.Count) = Array(sn(j), sn(j + 1), sn(j + 2), sn(j + 3), sn(j + 4), sn(j + 5), sn(j + 6), sn(j + 7), sn(j + 8), sn(j + 9))
    Next
 
    Cells(1, 2).Resize(.Count, 10) = Application.Index(.items, 0, 0)         '    schrijven
 End With
End Sub

 

[RoVo1211]

@snb: Ik ga jouw macro zo direct uitproberen. Toch leuk dat er zoveel wegen zijn die naar Rome leiden.
Verschillende oplossingen ontvangen voor mijn vraag, bedankt allen.

Ik weet niet of mijn vraag hier thuis hoort, maar het is een voortborduursel op mijn vorige vraag:
ik probeer de tabel die met mijn vorige vraag gecreëerd is, flexibel op te maken als tabel.


Als ik dat doe via macro opnemen, krijgt men altijd absolute celadressen. Omdat de tabellen niet altijd even lang zijn (wel even breed, nl. 10 kolommen (A:J)), probeer ik met

Sub OpmakenAlsTabel()
Dim Rows As Integer
Rows = WorksheetFunction.CountA([J:J])
Debug.Print Rows '=13 in dit voorbeeld

    Range("A1:J" & Rows).Select
'   Application.CutCopyMode = False
    ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , _
        xlYes).Name = "Tabel3"
    Range("Tabel3[#All]").Select
    ActiveSheet.ListObjects("Tabel3").TableStyle = "TableStyleLight6"
End Sub

Als ik de selection oproep achter 'xlSrcRange', krijg ik een foutmelding "Een tabel mag een andere tabel niet overlappen".
Dit heb ik handmatig gedaan, maar zo moet het worden:

Hoe krijg ik de grootte van een tabel flexibel?

 

[Warme bakkertje]

Lukt dit voor jou?

Sub M_snb()
  Call DeleteTable
  sn = Application.Transpose(Sheets("Blad1").UsedRange.Columns(1))                       '   lezen
 
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn) Step 10                                                       '   bewerken
      .Item(.Count) = Array(sn(j), sn(j + 1), sn(j + 2), sn(j + 3), sn(j + 4), sn(j + 5), sn(j + 6), sn(j + 7), sn(j + 8), sn(j + 9))
    Next
    Sheets("Blad2").Cells(1).CurrentRegion.ClearContents
    Sheets("Blad2").Cells(1).Resize(.Count, 10) = Application.Index(.items, 0, 0)         '    schrijven
  End With
  Call MakeTable
End Sub

Sub DeleteTable()
Dim rng As Range
On Error Resume Next
With Sheets("Blad2").ListObjects(1)
    Set rng = .Range
    .Unlist
    With rng
        .Interior.ColorIndex = xlColorIndexNone
        .Font.ColorIndex = xlColorIndexAutomatic
        .Borders.LineStyle = xlLineStyleNone
    End With
End With
End Sub

Sub MakeTable()
Dim tbl As ListObject
    With Sheets("Blad2")
        Set tbl = .ListObjects.Add(xlSrcRange, .Cells(1).CurrentRegion, , xlYes)
        tbl.Name = "Tabel3"
        tbl.TableStyle = "TableStyleLight6"
    End With
End Sub

 

[snb]

Alles in hetzelfde werkblad
Ik ga ervan uit dat alleen kolom A gegevens bevat.

Sub M_snb()
  sn = Application.Transpose(UsedRange.Columns(1))
 
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn) Step 10
      .Item(.Count) = Array(sn(j), sn(j + 1), sn(j + 2), sn(j + 3), sn(j + 4), sn(j + 5), sn(j + 6), sn(j + 7), sn(j + 8), sn(j + 9))
    Next
    
    Cells(1, 4).Resize(.Count, 10) = Application.Index(.items, 0, 0)
    ListObjects.Add 1, Cells(1, 4).CurrentRegion, , 1
 End With
End Sub