VBA Transpose Loop

  • I have data in columns B through F. I am needing it in the format of column A. I have tried the following VBA loop code. The 1st screen shot is the desired results and the 2nd screen shot is what the vba code is bringing back. It starts off copying and transposing correctly, but doesn't move down far enough before pasting and transposing the 2nd line and overwrites the data from the 1st. It needs to drop down 3 more lines before pasting. I am a vba novice and need help in this. Thanks in advance.


    Sub Macro1()

    ActiveCell.Offset(0, 2).Range("A1:D1").Select

    selection.Copy


    Do Until IsEmpty(ActiveCell)


    ActiveCell.Offset(4, -2).Range("A1").Select

    selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

    :=False, Transpose:=True

    ActiveCell.Offset(-3, 2).Range("A1:D1").Select

    Application.CutCopyMode = False

    selection.Copy

    Loop


    End


  • Pictures

    Will you please attach a sample Excel workbook? We are not able to work with or manipulate a picture of one and nobody wants to have to recreate your data from scratch.


    1. Make sure that your sample data are REPRESENTATIVE of your real data. The use of unrepresentative data is very frustrating and can lead to long delays in reaching a solution.


    2. Make sure that your desired results are also shown (mock up the results manually).


    3. Make sure that all confidential data is removed or replaced with dummy data first (e.g. names, addresses, E-mails, etc.).


    4. Try to avoid using merged cells as they cause lots of problems.


    Please pay particular attention to point 2 (above): without an idea of your intended outcomes, it is often very difficult to offer appropriate advice.



    This is a simple unpivot in Power Query. Upload your file and I will give you the solution.

  • If you have a real large range, an array might be faster.

    Code
    1. Sub Maybe()
    2. Dim i As Long
    3. For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
    4. Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(4).Value = Application.Transpose(Cells(i, 3).Resize(, 4).Value)
    5. Next i
    6. End Sub
  • If you are willing to use Power Query, here is a quick solution to unpivot the columns in question. Mcode below. File attached for your review.


    Code
    1. let
    2. Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    3. #"Unpivoted Columns" = Table.UnpivotOtherColumns(Source, {}, "Attribute", "Value"),
    4. #"Removed Columns" = Table.RemoveColumns(#"Unpivoted Columns",{"Attribute"})
    5. in
    6. #"Removed Columns"
  • And another possibility maybe

  • Change that code to

    Code
    1. Sub Transpose_Data_Loop()
    2. Dim i As Long
    3. Application.ScreenUpdating = False
    4. For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
    5. Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(4).Value = Application.Transpose(Cells(i, 3).Resize(, 4).Value)
    6. Next i
    7. Cells(1, 1).Delete Shift:=xlUp
    8. Application.ScreenUpdating = True
    9. End Sub

    That way you have 2 in your repertoire.

  • The code in Post #4 loops through the data cell by cell and you'll end up with an empty row in Sheet2.

    However, Sheet 2 ought to have headers and then you won't have that problem but since you indicated that you have an empty row, the code in post #10 will eliminate that problem. If you want, you can put headers in Sheet2 with code.

    The code in Post #8 puts everything into internal memory, does it job there and then pastes it in one go.

    So you can use whichever one you like, Post #8 or Post #10.

    Try each one on a copy of your workbook. It would be nice if you had several thousands of rows.

  • So you got me thinking about adding a header. I added one line at the top and a couple of additional columns. I was able to modified #8 and it seems to work, but which items would I modified in #10, if I had a line for the header and a couple of columns? Thanks!

  • Both as per your example in Mac sheet.


    Code
    1. Sub Transpose_Data_Loop()
    2. Dim i As Long
    3. Application.ScreenUpdating = False
    4. For i = 2 To Cells(Rows.Count, 3).End(xlUp).Row
    5. Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(6).Value = Application.Transpose(Cells(i, 3).Resize(, 6).Value)
    6. Next i
    7. Application.ScreenUpdating = True
    8. End Sub