Help with macro to transpose data

Question

I am in need of a macro to transpose rows into columns. I have been trying to figure it out with no success.
My data is in the format
1
A
B
C
x
y
z
2
D
E
F
p
q
r
3
G
H
I
m
n
o
and i need it to repeat the first few columns of each row but transpose the last few, so that,
1
A
B
C
x
1
A
B
C
y
1
A
B
C
z
2
D
E
F
p
2
D
E
F
q
2
D
E
F
r
3
G
H
I
m
3
G
H
I
n
3
G
H
I
o
This needs to repeat over 400 times. There are more columns then what i showed but I should be able to modify the code to make it work. If any one can help me I would be very thankful.
-Carl

Answer 1

Hi Carl,
Here is a sample code is for you reference. It should be able to achieve what your described, but not an elegant way.
Option Explicit
Sub test()
Dim arr, arr1, i&, j&, h&
Worksheets("sheet2").Cells.ClearContents
With Worksheets("sheet1")
arr = .Range("A1:G" & .[a10000].End(xlUp).Row)
End With
ReDim arr1(1 To UBound(arr) * 3, 1 To 5)
For i = 1 To UBound(arr)
    For j = 1 To 4
    h = (i) + (i - 1) * 2
    arr1(h, j) = arr(i, j)
    arr1(h + 1, j) = arr(i, j)
    arr1(h + 2, j) = arr(i, j)
    arr1(h, 5) = arr(i, 5)
    arr1(h + 1, 5) = arr(i, 6)
    arr1(h + 2, 5) = arr(i, 7)
    Next
Next
Worksheets("sheet2").[a1].Resize(UBound(arr1), 5) = arr1
End Sub
Wind Zhang
TechNet Community Support