Copying 3 rows of data one under the other in a stacked manner

[qwerty_logic]

Hi All,

I need to create a VBA code to execute the following task:

Current scenario -

• In Sheet1, I have data in column Z to column AQ
• 3 columns starting Column Z forms 1 set, i.e. Col Z, AA, AB is one set; AC, AD, AE will be set 2 and so on (total 6 sets).
• Data in one set has to be copy pasted one under the other (except the heading in row1)
• Final output required in Sheet2 from Cell A2

Thanks in advance !!

 

[Fishboy]

Yes, We need to copy and stack each row one under the other. The data is similar and we need to apply pivot on the final 3 columns. So no need to add separators after each set.

OK then, try this:

Sub TransposeAndStack()
' Defines variables
Dim x As Long, LastRow As Long, LastRow2 As Long, cRange As Range


' Defines LastRow as the last row of data on Sheet1 based on column Z
LastRow = Sheets("Sheet1").Cells(Rows.Count, "Z").End(xlUp).Row
' Defines LastRow2 as the first blank row of data on Sheet2 (assumes headers already exist in row 1)
LastRow2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1


' Sets check range as Z2 to the last row of Z
Set cRange = Sheets("Sheet1").Range("Z2:Z" & LastRow)


' For each cell in the check range
For Each Cell In cRange
    ' From column Z to AQ, in steps of 3
    For x = 26 To 43 Step 3
        ' Copy the current row of each set
        Sheets("Sheet1").Range(Cells(Cell.Row, x), Cells(Cell.Row, x + 2)).Copy
        ' Paste to the next blank row of Sheet2
        Sheets("Sheet2").Range("A" & LastRow).PasteSpecial xlPasteValues
        ' Increase LastRow by 1 to account for the new data
        LastRow = LastRow + 1
    ' Next set of 3 columns
    Next x
' Next cell in check range
Next Cell


End Sub

 

[qwerty_logic]

Getting an error at step - "Copy the current row of each set" (highlighted with red text-color). I have just modified the sheetnames as per my requirement. Please suggest.

------------------------------------------------------------------------------------------------

Sub TransposeAndStack()
' Defines variables
Dim x As Long, LastRow As Long, LastRow2 As Long, cRange As Range




' Defines LastRow as the last row of data on Sheet1 based on column Z
LastRow = Sheets("Rawdata").Cells(Rows.Count, "Z").End(xlUp).Row
' Defines LastRow2 as the first blank row of data on Sheet2 (assumes headers already exist in row 1)
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1




' Sets check range as Z2 to the last row of Z
Set cRange = Sheets("Rawdata").Range("Z2:Z" & LastRow)




' For each cell in the check range
For Each Cell In cRange
' From column Z to AQ, in steps of 3
For x = 26 To 43 Step 3
' Copy the current row of each set
Sheets("Rawdata").Range(Cells(Cell.Row, x), Cells(Cell.Row, x + 2)).Copy
' Paste to the next blank row of Sheet2
Sheets("Taxonomy").Range("A" & LastRow).PasteSpecial xlPasteValues
' Increase LastRow by 1 to account for the new data
LastRow = LastRow + 1
' Next set of 3 columns
Next x
' Next cell in check range
Next Cell




End Sub

 

[Fishboy]

Hmm, I have just spotted an error where I am referencing the wrong LastRow but that wouldn't give the error you are getting. You can download my test workbook with the corrected code from HERE

 

[qwerty_logic]

I downloaded the workbook you have created. In that workbook as well, getting the same runtime error: 1004. "Application defined or object defined error".

One more thing which I noticed in output sheet -

HEADERS	HEADERS	HEADERS
1A	1A	1A
1B	1B	1B

<colgroup><col width="64" span="3" style="width: 48pt;"></colgroup><tbody>
</tbody>

This is the output you are pulling. whereas I want it like

HEADERS	HEADERS	HEADERS
1A	1A	1A
2A	2A	2A
3A	3A	3A
4A	4A	4A
5A	5A	5A
6A	6A	6A
1B	1B	1B
2B	2B	2B
3B	3B	3B
4B	4B	4B
5B	5B	5B
6B	6B	6B

<colgroup><col width="64" span="3" style="width: 48pt;"></colgroup><tbody>
</tbody>

 

[Fishboy]

I see...

OK well I am not 100% sure why you would be getting the error message, the error number suggests that either there is a typo in the sheet name (when compared to the sheet name referenced in the code), or maybe the code has been placed in a worksheet module instead of a standard module. That said however I know that my own test workbook was functioning as intended so I am confused what is stopping it working at your end.

In the meantime however I can at least make sure the output is being processed in the way you want.

Leave it with me a little longer...

[EDIT]

This code (working at my end) now handles the data the way you have described above. I also added in a step which disables / re-enables screen updating to reduce flicker on screen. All that remains now is to work out why this is not working at your end...

Sub TransposeAndStack()
' Defines variables
Dim x As Long, LastRow As Long, LastRow2 As Long, cRange As Range


' Disable screen updating to reduce flicker
Application.ScreenUpdating = False


' Defines LastRow as the last row of data on Sheet1 based on column Z
LastRow = Sheets("Rawdata").Cells(Rows.Count, "Z").End(xlUp).Row
' Defines LastRow2 as the first blank row of data on Sheet2 (assumes headers already exist in row 1)
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1


' Sets check range as Z2 to the last row of Z
Set cRange = Sheets("Rawdata").Range("Z2:Z" & LastRow)


' For each cell in the check range
For Each Cell In cRange
    ' From column Z to AQ, in steps of 3
    For x = 26 To 43 Step 3
        ' Copy the current row of each set
        Sheets("Rawdata").Range(Cells(Cell.Row, x), Cells(LastRow, x + 2)).Copy
        ' Paste to the next blank row of Sheet2
        Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues
        ' Increase LastRow by 1 to account for the new data
        LastRow2 = LastRow2 + 1
    ' Next set of 3 columns
    Next x
' Next cell in check range
Next Cell


' Re-enable screen updating
Application.ScreenUpdating = True


End Sub

 

[qwerty_logic]

Hey.. Thanks for your support @fishboy. I don't know why I am still getting the same error.

Though, I was able to do it the hard way (without using loop for the iterations). Below mentioned code is working for me. I am not using the transpose functionality here as that was not my requirement.

Hope this may help others as well !!

Sub TransposeAndStack()
' Defines variables
Dim x As Long, LastRow As Long, LastRow2 As Long


' Disable screen updating to reduce flicker
Application.ScreenUpdating = False


' Defines LastRow as the last row of data on Rawdata based on column Z
LastRow = Sheets("Rawdata").Cells(Rows.Count, "Z").End(xlUp).Row
' Defines LastRow2 as the first blank row of data on Taxonomy (assumes headers already exist in row 1)
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1


' Set-wise copy and paste data: Z2 to the last row of Z


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("Z2:AB" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AC2:AE" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AF2:AH" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AI2:AK" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AL2:AN" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AO2:AQ" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


' Re-enable screen updating
Application.ScreenUpdating = True


End Sub

 

[Fishboy]

Hey.. Thanks for your support @fishboy. I don't know why I am still getting the same error.

Though, I was able to do it the hard way (without using loop for the iterations). Below mentioned code is working for me. I am not using the transpose functionality here as that was not my requirement.

Hope this may help others as well !!

Sub TransposeAndStack()
' Defines variables
Dim x As Long, LastRow As Long, LastRow2 As Long


' Disable screen updating to reduce flicker
Application.ScreenUpdating = False


' Defines LastRow as the last row of data on Rawdata based on column Z
LastRow = Sheets("Rawdata").Cells(Rows.Count, "Z").End(xlUp).Row
' Defines LastRow2 as the first blank row of data on Taxonomy (assumes headers already exist in row 1)
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1


' Set-wise copy and paste data: Z2 to the last row of Z


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("Z2:AB" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AC2:AE" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AF2:AH" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AI2:AK" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AL2:AN" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


ActiveWorkbook.Worksheets("Rawdata").Activate
ActiveWorkbook.Worksheets("Rawdata").Range("AO2:AQ" & LastRow).Select
Selection.Copy
Sheets("Taxonomy").Activate
LastRow2 = Sheets("Taxonomy").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Taxonomy").Range("A" & LastRow2).PasteSpecial xlPasteValues


' Re-enable screen updating
Application.ScreenUpdating = True


End Sub

Technically my code never actually used the transpose function within Excel, however in effect what we were doing was transposing data which is how that made its way into the sub name.

I am sorry we couldn't get to the bottom of why you were getting the error, however I am glad to hear that you now have a working macro based on snippets of my code. At least you managed to pick up enough suitable code out of it that you could write your own solution.