Transpose and VBA Resize command
 

Dear All,

Thanks to Bernie I have solved a big problem. (Bernie, I started a new
thread in case you wouldn't pick it up in the old one.)

The code below provided by Bernie is working really well. There is one
slight problem - the speed of the execution when there is a large amount of
data. If I turn the calculation off before and back on after it does not
improve the speed. It seems to be down to the Resize command. Is there a way
to make it faster? Any help much appreciated.

Sub MartinDataRearrange()
Dim myA As Range
Dim myR As Range
Dim mySel As String
Dim myRow As Long
Dim i As Long

mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

myRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = myRow To 2 Step -1
Cells(i, 1).EntireRow.Copy
Cells(i, 1).Resize(9).Insert
Cells(i, 1).Offset(1, 11).Resize(9, 244).ClearContents
Next i

Set myR = Range("L2:U2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 2).Resize(10).PasteSpecial Transpose:=True
Next myA

Set myR = Range("V2:AE2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 4).Resize(10).PasteSpecial Transpose:=True
Next myA

Range("L:AE").EntireColumn.Delete

Range(mySel).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

--
Regards,

Martin

Transpose and VBA Resize command
 

This seems to produce the same output and should be Faster.

Sub MartinDataRearrangeV2()
Dim mySel As String
Dim myRow As Long, i As Long
Dim j As Long, k As Long
Dim v As Variant, vB As Variant
Dim vD As Variant, cnt As Long
Dim vAK As Variant, vAK_Exp As Variant
mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
myRow = Cells(Rows.Count, 1).End(xlUp).Row
cnt = myRow - 1
ReDim vB(1 To cnt * 10, 1 To 1)
ReDim vD(1 To cnt * 10, 1 To 1)
ReDim vAK_Exp(1 To cnt * 10, 1 To 11)

v = Range("L2:AE" & myRow)
vAK = Range("A2:K" & myRow)
For i = 1 To cnt
For j = 1 To 10
vB((i - 1) * 10 + j, 1) = v(i, j)
Next j
For j = 11 To 20
vD((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For k = 1 To 10
For j = 1 To 11
vAK_Exp((i - 1) * 10 + k, j) = vAK(i, j)
Next
Next
Next i
Range("A2:K" & cnt * 10 + 1).Value = vAK_Exp
Range("B2:B" & cnt * 10 + 1) = vB
Range("D2:D" & cnt * 10 + 1) = vD
Range("L:AE").EntireColumn.Delete
End Sub

--
Regards,
Tom Ogilvy


"Martin" wrote:

Dear All,

Thanks to Bernie I have solved a big problem. (Bernie, I started a new
thread in case you wouldn't pick it up in the old one.)

The code below provided by Bernie is working really well. There is one
slight problem - the speed of the execution when there is a large amount of
data. If I turn the calculation off before and back on after it does not
improve the speed. It seems to be down to the Resize command. Is there a way
to make it faster? Any help much appreciated.

Sub MartinDataRearrange()
Dim myA As Range
Dim myR As Range
Dim mySel As String
Dim myRow As Long
Dim i As Long

mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

myRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = myRow To 2 Step -1
Cells(i, 1).EntireRow.Copy
Cells(i, 1).Resize(9).Insert
Cells(i, 1).Offset(1, 11).Resize(9, 244).ClearContents
Next i

Set myR = Range("L2:U2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 2).Resize(10).PasteSpecial Transpose:=True
Next myA

Set myR = Range("V2:AE2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 4).Resize(10).PasteSpecial Transpose:=True
Next myA

Range("L:AE").EntireColumn.Delete

Range(mySel).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

--
Regards,

Martin

Transpose and VBA Resize command
 

Thanks Tom,

That seems to be working like a dream. However, sorry for being so stupid
but I was then trying amend the code into a bigger picture and cannot get it
to work. A wider range and more sets of data to transpose. I would appreciate
a lot if you were able to help and see why it is going wrong.


Sub MartinDataRearrangeV2()
Dim mySel As String
Dim myRow As Long, i As Long
Dim j As Long, k As Long
Dim v As Variant, vV As Variant, vW As Variant, vX As Variant, vY As Variant
Dim vB As Variant, vAE As Variant, vAF As Variant, vAG As Variant, vAH As
Variant, cnt As Long
Dim vAAH As Variant, vAAH_Exp As Variant
mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
myRow = Cells(Rows.Count, 1).End(xlUp).Row
cnt = myRow - 1
ReDim vV(1 To cnt * 10, 1 To 1)
ReDim vW(1 To cnt * 10, 1 To 1)
ReDim vX(1 To cnt * 10, 1 To 1)
ReDim vY(1 To cnt * 10, 1 To 1)
ReDim vB(1 To cnt * 10, 1 To 1)
ReDim vAE(1 To cnt * 10, 1 To 1)
ReDim vAF(1 To cnt * 10, 1 To 1)
ReDim vAG(1 To cnt * 10, 1 To 1)
ReDim vAH(1 To cnt * 10, 1 To 1)

ReDim vAAH_Exp(1 To cnt * 10, 1 To 34)

v = Range("AI2:DT" & myRow)
vAAB = Range("A2:AH" & myRow)
For i = 1 To cnt
For j = 1 To 10
vV((i - 1) * 10 + j, 1) = v(i, j)
Next j
For j = 11 To 20
vW((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 21 To 30
vX((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 31 To 40
vY((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 41 To 50
vB((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 51 To 60
vAE((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 61 To 70
vAF((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 71 To 80
vAG((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 81 To 90
vAH((i - 1) * 10 + j - 10, 1) = v(i, j)
Next

For k = 1 To 10
For j = 1 To 34
vAAH_Exp((i - 1) * 10 + k, j) = vAAH(i, j)
Next
Next
Next i
Range("A2:AH" & cnt * 10 + 1).Value = vAAH_Exp
Range("AI2:AR" & cnt * 10 + 1) = vV
Range("AS2:BB" & cnt * 10 + 1) = vW
Range("BC2:BL" & cnt * 10 + 1) = vX
Range("BM2:BV" & cnt * 10 + 1) = vY
Range("BW2:CF" & cnt * 10 + 1) = vB
Range("CG2:CP" & cnt * 10 + 1) = vAE
Range("CQ2:CZ" & cnt * 10 + 1) = vAF
Range("DA2:DJ" & cnt * 10 + 1) = vAG
Range("DK2:DT" & cnt * 10 + 1) = vAH

Range("AI:DT").EntireColumn.Delete
End Sub


--
Regards,

Martin


"Tom Ogilvy" wrote:

This seems to produce the same output and should be Faster.

Sub MartinDataRearrangeV2()
Dim mySel As String
Dim myRow As Long, i As Long
Dim j As Long, k As Long
Dim v As Variant, vB As Variant
Dim vD As Variant, cnt As Long
Dim vAK As Variant, vAK_Exp As Variant
mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
myRow = Cells(Rows.Count, 1).End(xlUp).Row
cnt = myRow - 1
ReDim vB(1 To cnt * 10, 1 To 1)
ReDim vD(1 To cnt * 10, 1 To 1)
ReDim vAK_Exp(1 To cnt * 10, 1 To 11)

v = Range("L2:AE" & myRow)
vAK = Range("A2:K" & myRow)
For i = 1 To cnt
For j = 1 To 10
vB((i - 1) * 10 + j, 1) = v(i, j)
Next j
For j = 11 To 20
vD((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For k = 1 To 10
For j = 1 To 11
vAK_Exp((i - 1) * 10 + k, j) = vAK(i, j)
Next
Next
Next i
Range("A2:K" & cnt * 10 + 1).Value = vAK_Exp
Range("B2:B" & cnt * 10 + 1) = vB
Range("D2:D" & cnt * 10 + 1) = vD
Range("L:AE").EntireColumn.Delete
End Sub

--
Regards,
Tom Ogilvy


"Martin" wrote:

Dear All,

Thanks to Bernie I have solved a big problem. (Bernie, I started a new
thread in case you wouldn't pick it up in the old one.)

The code below provided by Bernie is working really well. There is one
slight problem - the speed of the execution when there is a large amount of
data. If I turn the calculation off before and back on after it does not
improve the speed. It seems to be down to the Resize command. Is there a way
to make it faster? Any help much appreciated.

Sub MartinDataRearrange()
Dim myA As Range
Dim myR As Range
Dim mySel As String
Dim myRow As Long
Dim i As Long

mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

myRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = myRow To 2 Step -1
Cells(i, 1).EntireRow.Copy
Cells(i, 1).Resize(9).Insert
Cells(i, 1).Offset(1, 11).Resize(9, 244).ClearContents
Next i

Set myR = Range("L2:U2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 2).Resize(10).PasteSpecial Transpose:=True
Next myA

Set myR = Range("V2:AE2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 4).Resize(10).PasteSpecial Transpose:=True
Next myA

Range("L:AE").EntireColumn.Delete

Range(mySel).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

--
Regards,

Martin

Transpose and VBA Resize command
 

It is hard to tell what you are trying to do, but you dimension your arrays
to be a single column, then when you write them to the worksheet, you write
them to a multicolumn range.

Are you trying to have multiple columns all with the same information or
should you be constructing and populating your arrays differently?

--
Regards,
Tom Ogilvy


"Martin" wrote:

Thanks Tom,

That seems to be working like a dream. However, sorry for being so stupid
but I was then trying amend the code into a bigger picture and cannot get it
to work. A wider range and more sets of data to transpose. I would appreciate
a lot if you were able to help and see why it is going wrong.


Sub MartinDataRearrangeV2()
Dim mySel As String
Dim myRow As Long, i As Long
Dim j As Long, k As Long
Dim v As Variant, vV As Variant, vW As Variant, vX As Variant, vY As Variant
Dim vB As Variant, vAE As Variant, vAF As Variant, vAG As Variant, vAH As
Variant, cnt As Long
Dim vAAH As Variant, vAAH_Exp As Variant
mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
myRow = Cells(Rows.Count, 1).End(xlUp).Row
cnt = myRow - 1
ReDim vV(1 To cnt * 10, 1 To 1)
ReDim vW(1 To cnt * 10, 1 To 1)
ReDim vX(1 To cnt * 10, 1 To 1)
ReDim vY(1 To cnt * 10, 1 To 1)
ReDim vB(1 To cnt * 10, 1 To 1)
ReDim vAE(1 To cnt * 10, 1 To 1)
ReDim vAF(1 To cnt * 10, 1 To 1)
ReDim vAG(1 To cnt * 10, 1 To 1)
ReDim vAH(1 To cnt * 10, 1 To 1)

ReDim vAAH_Exp(1 To cnt * 10, 1 To 34)

v = Range("AI2:DT" & myRow)
vAAB = Range("A2:AH" & myRow)
For i = 1 To cnt
For j = 1 To 10
vV((i - 1) * 10 + j, 1) = v(i, j)
Next j
For j = 11 To 20
vW((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 21 To 30
vX((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 31 To 40
vY((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 41 To 50
vB((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 51 To 60
vAE((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 61 To 70
vAF((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 71 To 80
vAG((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 81 To 90
vAH((i - 1) * 10 + j - 10, 1) = v(i, j)
Next

For k = 1 To 10
For j = 1 To 34
vAAH_Exp((i - 1) * 10 + k, j) = vAAH(i, j)
Next
Next
Next i
Range("A2:AH" & cnt * 10 + 1).Value = vAAH_Exp
Range("AI2:AR" & cnt * 10 + 1) = vV
Range("AS2:BB" & cnt * 10 + 1) = vW
Range("BC2:BL" & cnt * 10 + 1) = vX
Range("BM2:BV" & cnt * 10 + 1) = vY
Range("BW2:CF" & cnt * 10 + 1) = vB
Range("CG2:CP" & cnt * 10 + 1) = vAE
Range("CQ2:CZ" & cnt * 10 + 1) = vAF
Range("DA2:DJ" & cnt * 10 + 1) = vAG
Range("DK2:DT" & cnt * 10 + 1) = vAH

Range("AI:DT").EntireColumn.Delete
End Sub


--
Regards,

Martin


"Tom Ogilvy" wrote:

This seems to produce the same output and should be Faster.

Sub MartinDataRearrangeV2()
Dim mySel As String
Dim myRow As Long, i As Long
Dim j As Long, k As Long
Dim v As Variant, vB As Variant
Dim vD As Variant, cnt As Long
Dim vAK As Variant, vAK_Exp As Variant
mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
myRow = Cells(Rows.Count, 1).End(xlUp).Row
cnt = myRow - 1
ReDim vB(1 To cnt * 10, 1 To 1)
ReDim vD(1 To cnt * 10, 1 To 1)
ReDim vAK_Exp(1 To cnt * 10, 1 To 11)

v = Range("L2:AE" & myRow)
vAK = Range("A2:K" & myRow)
For i = 1 To cnt
For j = 1 To 10
vB((i - 1) * 10 + j, 1) = v(i, j)
Next j
For j = 11 To 20
vD((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For k = 1 To 10
For j = 1 To 11
vAK_Exp((i - 1) * 10 + k, j) = vAK(i, j)
Next
Next
Next i
Range("A2:K" & cnt * 10 + 1).Value = vAK_Exp
Range("B2:B" & cnt * 10 + 1) = vB
Range("D2:D" & cnt * 10 + 1) = vD
Range("L:AE").EntireColumn.Delete
End Sub

--
Regards,
Tom Ogilvy


"Martin" wrote:

Dear All,

Thanks to Bernie I have solved a big problem. (Bernie, I started a new
thread in case you wouldn't pick it up in the old one.)

The code below provided by Bernie is working really well. There is one
slight problem - the speed of the execution when there is a large amount of
data. If I turn the calculation off before and back on after it does not
improve the speed. It seems to be down to the Resize command. Is there a way
to make it faster? Any help much appreciated.

Sub MartinDataRearrange()
Dim myA As Range
Dim myR As Range
Dim mySel As String
Dim myRow As Long
Dim i As Long

mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

myRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = myRow To 2 Step -1
Cells(i, 1).EntireRow.Copy
Cells(i, 1).Resize(9).Insert
Cells(i, 1).Offset(1, 11).Resize(9, 244).ClearContents
Next i

Set myR = Range("L2:U2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 2).Resize(10).PasteSpecial Transpose:=True
Next myA

Set myR = Range("V2:AE2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 4).Resize(10).PasteSpecial Transpose:=True
Next myA

Range("L:AE").EntireColumn.Delete

Range(mySel).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

--
Regards,

Martin

Transpose and VBA Resize command
 

Hi Tom,

Please find below an explanation of what I was trying to change the code into.

Lets say we have 50 rows of data. (The number of rows could vary from 1 to
around 8000 to 10,000):

1. Add 9 empty rows after each row of data. After this exercise we should
have 500 rows. 50 with data and another 450 without any data.

2. Now I want to copy the A2:AH2 down to A3:AH11. (No transposing yet)

3. Then A12:AH12 to A13:AH21. (No transposing yet)

4. Then A22:AH22 to A23:AH31 until all the emtpy rows are taken care of (No
transposing yet)

5. Now it's time for transposing. The data in AI2:AR2 (10 cells) to be
copied into V2:V11 (10 cells), AS2:BB2 into W2:W11, BC2:BL2 into X2:X11,
BM2:BV2 into Y2:Y11, BW2:CF2 into B2:B11, CG2:CP2 into AE2:AE11, CQ2:CZ2 into
AF2:AF11, DA2:DJ2 into AG2:AG11 and DK2:DT2 into AH2:AH11

6. The data in AI12:AR12 (10 cells) to be copied into V12:V21 (10 cells),
AS12:BB12 into W12:W21, BC12:BL12 into X12:X21, BM12:BV12 into Y12:Y21,
BW12:CF12 into B12:B21, CG12:CP12 into AE12:AE21, CQ12:CZ12 into AF12:AF21,
DA12:DJ12 into AG12:AG21 and DK12:DT12 into AH12:AH21


7. The data in AI22:AR22 (10 cells) to be copied into V22:V31 (10 cells),
AS22:BB22 into W22:W31, BC22:BL22 into X22:X31, BM22:BV22 into Y22:Y31,
BW22:CF22 into B22:B31, CG22:CP22 into AE22:AE31, CQ22:CZ22 into AF22:AF31,
DA22:DJ22 into AG22:AG31 and DK22:DT22 into AH22:AH31 until all the 50 sets
of have been taken care of.

--
Thanks a lot for your help and kind regards,

Martin


"Tom Ogilvy" wrote:

It is hard to tell what you are trying to do, but you dimension your arrays
to be a single column, then when you write them to the worksheet, you write
them to a multicolumn range.

Are you trying to have multiple columns all with the same information or
should you be constructing and populating your arrays differently?

--
Regards,
Tom Ogilvy


"Martin" wrote:

Thanks Tom,

That seems to be working like a dream. However, sorry for being so stupid
but I was then trying amend the code into a bigger picture and cannot get it
to work. A wider range and more sets of data to transpose. I would appreciate
a lot if you were able to help and see why it is going wrong.


Sub MartinDataRearrangeV2()
Dim mySel As String
Dim myRow As Long, i As Long
Dim j As Long, k As Long
Dim v As Variant, vV As Variant, vW As Variant, vX As Variant, vY As Variant
Dim vB As Variant, vAE As Variant, vAF As Variant, vAG As Variant, vAH As
Variant, cnt As Long
Dim vAAH As Variant, vAAH_Exp As Variant
mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
myRow = Cells(Rows.Count, 1).End(xlUp).Row
cnt = myRow - 1
ReDim vV(1 To cnt * 10, 1 To 1)
ReDim vW(1 To cnt * 10, 1 To 1)
ReDim vX(1 To cnt * 10, 1 To 1)
ReDim vY(1 To cnt * 10, 1 To 1)
ReDim vB(1 To cnt * 10, 1 To 1)
ReDim vAE(1 To cnt * 10, 1 To 1)
ReDim vAF(1 To cnt * 10, 1 To 1)
ReDim vAG(1 To cnt * 10, 1 To 1)
ReDim vAH(1 To cnt * 10, 1 To 1)

ReDim vAAH_Exp(1 To cnt * 10, 1 To 34)

v = Range("AI2:DT" & myRow)
vAAB = Range("A2:AH" & myRow)
For i = 1 To cnt
For j = 1 To 10
vV((i - 1) * 10 + j, 1) = v(i, j)
Next j
For j = 11 To 20
vW((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 21 To 30
vX((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 31 To 40
vY((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 41 To 50
vB((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 51 To 60
vAE((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 61 To 70
vAF((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 71 To 80
vAG((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For j = 81 To 90
vAH((i - 1) * 10 + j - 10, 1) = v(i, j)
Next

For k = 1 To 10
For j = 1 To 34
vAAH_Exp((i - 1) * 10 + k, j) = vAAH(i, j)
Next
Next
Next i
Range("A2:AH" & cnt * 10 + 1).Value = vAAH_Exp
Range("AI2:AR" & cnt * 10 + 1) = vV
Range("AS2:BB" & cnt * 10 + 1) = vW
Range("BC2:BL" & cnt * 10 + 1) = vX
Range("BM2:BV" & cnt * 10 + 1) = vY
Range("BW2:CF" & cnt * 10 + 1) = vB
Range("CG2:CP" & cnt * 10 + 1) = vAE
Range("CQ2:CZ" & cnt * 10 + 1) = vAF
Range("DA2:DJ" & cnt * 10 + 1) = vAG
Range("DK2:DT" & cnt * 10 + 1) = vAH

Range("AI:DT").EntireColumn.Delete
End Sub


--
Regards,

Martin


"Tom Ogilvy" wrote:

This seems to produce the same output and should be Faster.

Sub MartinDataRearrangeV2()
Dim mySel As String
Dim myRow As Long, i As Long
Dim j As Long, k As Long
Dim v As Variant, vB As Variant
Dim vD As Variant, cnt As Long
Dim vAK As Variant, vAK_Exp As Variant
mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
myRow = Cells(Rows.Count, 1).End(xlUp).Row
cnt = myRow - 1
ReDim vB(1 To cnt * 10, 1 To 1)
ReDim vD(1 To cnt * 10, 1 To 1)
ReDim vAK_Exp(1 To cnt * 10, 1 To 11)

v = Range("L2:AE" & myRow)
vAK = Range("A2:K" & myRow)
For i = 1 To cnt
For j = 1 To 10
vB((i - 1) * 10 + j, 1) = v(i, j)
Next j
For j = 11 To 20
vD((i - 1) * 10 + j - 10, 1) = v(i, j)
Next
For k = 1 To 10
For j = 1 To 11
vAK_Exp((i - 1) * 10 + k, j) = vAK(i, j)
Next
Next
Next i
Range("A2:K" & cnt * 10 + 1).Value = vAK_Exp
Range("B2:B" & cnt * 10 + 1) = vB
Range("D2:D" & cnt * 10 + 1) = vD
Range("L:AE").EntireColumn.Delete
End Sub

--
Regards,
Tom Ogilvy


"Martin" wrote:

Dear All,

Thanks to Bernie I have solved a big problem. (Bernie, I started a new
thread in case you wouldn't pick it up in the old one.)

The code below provided by Bernie is working really well. There is one
slight problem - the speed of the execution when there is a large amount of
data. If I turn the calculation off before and back on after it does not
improve the speed. It seems to be down to the Resize command. Is there a way
to make it faster? Any help much appreciated.

Sub MartinDataRearrange()
Dim myA As Range
Dim myR As Range
Dim mySel As String
Dim myRow As Long
Dim i As Long

mySel = Selection.Address

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

myRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = myRow To 2 Step -1
Cells(i, 1).EntireRow.Copy
Cells(i, 1).Resize(9).Insert
Cells(i, 1).Offset(1, 11).Resize(9, 244).ClearContents
Next i

Set myR = Range("L2:U2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 2).Resize(10).PasteSpecial Transpose:=True
Next myA

Set myR = Range("V2:AE2").Resize((myRow - 2) * 10 + 1). _
SpecialCells(xlCellTypeConstants)

For Each myA In myR.Areas
myA.Cells.Copy
Cells(myA.Cells(1, 1).Row, 4).Resize(10).PasteSpecial Transpose:=True
Next myA

Range("L:AE").EntireColumn.Delete

Range(mySel).Select

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

--
Regards,

Martin