Transponeren van steeds 3 rows

[W1llem]

Ik heb een bestand van ca 1200 regels dat bestaat uit iedere keer 4 regels die in dezelfde volgorde staan onder elkaar. die wil ik in 4 kolommen zetten.
Ik heb het geprobeerd op 2 verschillende manieren op te lossen maar volgens mij moet het een stuk korter kunnen...
Graag hulp

1.
Sub trans2()

Range("I2") = "In aanleg"
Range("J2") = "Gereed"
Range("K2") = "Offertes"

Range("H4:H6").Copy
Range("I3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H8:H10").Copy
Range("I7").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H12:H14").Copy
Range("I11").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H16:H18").Copy
Range("I15").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H20:H22").Copy
Range("I19").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H24:H26").Copy
Range("I23").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H28:H30").Copy
Range("I27").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H32:H34").Copy
Range("I31").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

' Regels waar getransponeerde cellen vandaan komen verwijderen
ActiveWorkbook.Sheets("Blad1").Range("j4:j35").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

of

2.
Sub trans3()
'
' trans3 Macro
'

Range("I2") = "In aanleg"
Range("J2") = "Gereed"
Range("K2") = "Offertes"
Range("I3").Select
Application.CutCopyMode = False

' in plaats van transponeren hier met formules kopieren
ActiveCell.FormulaR1C1 = "=+R[1]C[-1]"
Range("J3").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=+R[2]C[-2]"
Range("K3").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=+R[3]C[-3]"

' eerst 1 regel copy/paste, daarna dubbel grote stukken copy/paste; 1,2,4,8,16,32 etc
Range("I3:K3").Copy
Range("I7").Select
ActiveSheet.Paste
Range("I3:K7").Copy
Range("I11").Select
ActiveSheet.Paste
Range("I3:K15").Copy
Range("I19").Select
ActiveSheet.Paste

' formules omzetten naar waarden
Columns("I:K").Copy
Range("I1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

ActiveWorkbook.Sheets("Blad1").Range("i3:i34").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Range("g10").Select

End Sub

 

[JEC.]

Geen macro voor nodig. Met draaitabel of formule

 

[W1llem]

Bedankt JVeer :thumb:

Inderdaad veul beter/sneller ja

 

[HSV]

Geen matrix en korter.

=INDEX($H$3:$H$34;(RIJ(A1))*4-4+KOLOM(A1))

 

[W1llem]

Bedankt HSV, dat is inderdaad erg kort.

Als ik me niet vergis heb ik dan 1200 formules
Omdat het aantal rijen niet steeds gelijk is moet ik daar iets op verzinnen

 

[JEC.]

Gebruik de draaitabel. Dan heb je geen formules

 

[VenA]

Kleine aanvulling op de reactie in #6 Maak van de gegevens een tabel, gebruik een hulpkolom en gebruik vervolgens een draaitabel.

Nb. Zet de code in het eerste bericht even tussen codetags. Nu is het onleesbaar.

 

[W1llem]

Daar moet ik het in dit geval helaas mee eens zijn alhoewel ik op de door jou neergezette formules op blad1 nog even moet studeren

 

[VenA]

Op welke reactie reageer je nu?

 

[W1llem]

Excuus, dat een draaitafel hier verkozen wordt.

Met betrekking tot de formules het eerste antwoord van Jveer