Dele en kolonne

Option Explicit

Dim ws As Worksheet, wsNew As Worksheet
Dim rArea As Range, rNewArea As Range
Dim myArray() As Variant
Dim colMyCol As New Collection
Dim iAreas, iCount, iCountB, iCountC, iRow, iMyArray As Integer
Const iColumn = 6

Sub TilpasArk()
    Set ws = ActiveSheet
   
    iAreas = (ws.UsedRange.Columns.Count + 1) / 6
    iRow = ws.UsedRange.Rows.Count + 3
    For iCount = 1 To iAreas
        Set rArea = ws.Range(Cells(3, 1 + (iColumn * (iCount - 1))), Cells(iRow, 5 + (iColumn * (iCount - 1))))
        myArray = rArea
        colMyCol.Add myArray
    Next
    Set wsNew = Sheets.Add
    For iCount = 1 To iAreas
        myArray = colMyCol.Item(iCount)
        Set rArea = wsNew.Range(Cells(3, 1 + (iColumn * (iCount - 1))), Cells(iRow * 2 - 3, 5 + (iColumn * (iCount - 1))))
        iMyArray = 0
        For iCountB = 3 To iRow * 2 - 3 Step 2
            iMyArray = iMyArray + 1
            For iCountC = 1 To 4
                wsNew.Range(Cells(iCountB, iCountC + iColumn * (iCount - 1)), Cells(iCountB + 1, iCountC + iColumn * (iCount - 1))).Merge
                wsNew.Cells(iCountB, iCountC + iColumn * (iCount - 1)).Value = myArray(iMyArray, iCountC)
                wsNew.Cells(iCountB, iCountC + iColumn * (iCount - 1)).VerticalAlignment = xlTop
            Next
            wsNew.Cells(iCountB, 5 + iColumn * (iCount - 1)).Value = myArray(iMyArray, 5)
        Next
    Next
   
    ws.Activate
End Sub