Solved: Transpose in diffrent rows

[lolos]

I want to Transpose Data from Columns to Rows with a feature to start a New Row for each New Record which is identified by an empty Row each data set in my column has different number of rows!
I use excel 2003
So what i want is to have each data set aaaa, bbbb, etc which is from about 7 to 20 rows and after is a blank cell to be in rows and each one starts with the first row after the blank!
thanks in advance.

1aaaa 1aaaa 2aaaa 3aaaa 4aaaa 5aaaa
2aaaa 1bbbb 2bbbb
3aaaa 1cccc 2cccc 3cccc
4aaaa
5aaaa

1bbbb
2bbbb

1cccc
2cccc
3cccc

[mikerickson]

I'm not sure if this is what you want. It will turn

a aa aaab bb
c cc ccc

into
a
aa
aaa

b
bb

c
cc
ccc

Sub test()
Dim originalRange As Range, readThisRange As Range
Dim destinationTopCell As Range
Dim dataRRay As Variant, outputRRay As Variant
Dim i As Long, j As Long, rowPointer As Long

Set originalRange = ThisWorkbook.Sheets(1).Range("a2:c3")
Set destinationTopCell = ThisWorkbook.Sheets(1).Range("d15")

Set readThisRange = originalRange.Range("a1")
For i = 1 To originalRange.Rows.Count
    Set readThisRange = Range(originalRange.Cells(i, 1).EntireRow.Range("ie1").End(xlToLeft) _
                                        , readThisRange)
Next i
dataRRay = readThisRange.Value
With readThisRange
    ReDim outputRRay(1 To (UBound(dataRRay, 2) * (UBound(dataRRay, 1) + 1)))
End With
i = 1
Do
    For j = 1 To UBound(dataRRay, 2)
        If dataRRay(i, j) = vbNullString Then Exit For
        rowPointer = rowPointer + 1
        outputRRay(rowPointer) = dataRRay(i, j)
    Next j
    rowPointer = rowPointer + 1
    i = i + 1
Loop Until i > UBound(dataRRay, 1)
ReDim Preserve outputRRay(1 To rowPointer)
With destinationTopCell
    Range(.Range("a1"), .Cells(rowPointer, 1)).Value = Application.Transpose(outputRRay)
End With
End Sub

originalRange and destinationTopCell need to be changed to meet your situation.

[lolos]

i want tis column :
1aaaa
2aaaa
3aaaa
4aaaa
blank
1bb
2bb
blank
1cccc
2cccc
3cccc
blank
1wwwwww
2wwwwww
3wwwwww
blank

to become

1aaaa 2aaaa 3aaaa 4aaaa
1bb 2bb
1cccc 2cccc 3cccc
1wwwwww 2wwwwww 3wwwwww
so each new record (row) stert after the blank cell.
Now its new record has x number of cells!

[mikerickson]

This should do what you want.

Sub test2()
Dim inputColumn As Range, readThisRange As Range
Dim upLeftOutput
Dim dataRRay As Variant, outputRRay As Variant
Dim colOut As Long, rowOut As Long, readPointer As Long
Dim blankCount As Long, numColOut As Long
Set inputColumn = ThisWorkbook.Sheets("sheet1").Range("a2:a5")
Set upLeftOutput = ThisWorkbook.Sheets("sheet1").Range("b1")
Set readThisRange = Range(inputColumn.Range("a1"), _
                inputColumn.Range("a1").EntireColumn.Range("a65536").End(xlUp))

On Error Resume Next
blankCount = readThisRange.SpecialCells(xlCellTypeBlanks).Cells.Count
On Error GoTo 0
dataRRay = Application.Transpose(readThisRange.Value)
ReDim outputRRay(1 To (blankCount + 1), 1 To UBound(dataRRay))
rowOut = 1
Do
    For colOut = 1 To UBound(dataRRay)
        readPointer = readPointer + 1
        If readPointer > UBound(dataRRay) Then Exit For
        If dataRRay(readPointer) = vbNullString Then Exit For
        outputRRay(rowOut, colOut) = dataRRay(readPointer)
    Next colOut
    If numColOut < colOut Then numColOut = colOut
    rowOut = rowOut + 1
Loop Until rowOut > blankCount + 1
If numColOut > UBound(dataRRay) Then numColOut = UBound(dataRRay)
With upLeftOutput.Range("a1")
    Range(.Range("a1"), .Cells(blankCount + 1, numColOut)).Value = outputRRay
    
End With
End Sub

[lolos]

It dosent seem to work or i do somthing wrong.
I will try more and come back.
Anyhow thank you!

[mikerickson]

You may need to ajust the variables inputColumn (a range) and upLeftOutput (another range).