Help with Transpose Macros/VBA/Formula

[Beth123]

Hello, I need help on a transpose problem in Excel 2013. I have a set of data that has all it's information in one column and I would like take the cells and split them up into individual rows.

Here is my data (the information has been changed because I don't want to add sensitive information from my job):

Red
White
Blue
Green
Yellow
Pink
Purple
Black
Brown
Red
White
Blue
Green
Yellow
Pink
Purple
Black
Brown

And I would like for every 9th cell to form a new row, so it reads like this:

Row 1 - Red White Blue Green Yellow Pink Purple Black Brown
Row 2 - Red White Blue Green Yellow Pink Purple Black Brown


I have 1400 cells in one row and I need to split them up into rows by every 9th cell. I have tried and exhausted different macros and I don't know what to do. I'm open to different solutions, as long as it means that I can take this data and properly transpose it.

Thanks,

Beth123

 

[Joe4]

Welcome to the Board!

Try this macro out. Just be sure to set the proper starting row in the code:

Sub MyTransposeMacro()

    Dim myStartRow As Long
    Dim myJump As Long
    Dim myLastRow As Long
    Dim myRow As Long
    
    Application.ScreenUpdating = False
        
'   Define starting row an number of rows to transpose in each row
    myStartRow = 2
    myJump = 9
        
'   Find last row in column A
    myLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Loop through all rows
    myRow = myStartRow
    Do Until myRow >= myLastRow
        Range(Cells(myRow, "A"), Cells(myRow + myJump - 1, "A")).Copy
        Cells(myRow, "B").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Application.CutCopyMode = False
        myRow = myRow + myJump
    Loop

'   Delete column A
    Columns("A").Delete
    
'   Select all blank rows and delete
    Range(Cells(myStartRow, "A"), Cells(myLastRow, "A")).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    Application.ScreenUpdating = True

End Sub

 

[VBA Geek]

try like this

Sub trnsp()
Dim x As Long
Application.ScreenUpdating = False
For x = 1 To Range("A" & Rows.Count).End(xlUp).Row Step 9
    Range("A" & x).Resize(9).Copy
    Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, True
Next x
Application.CutCopyMode = False
End Sub