transpose data from vertical to horizontalSolved/Closed

Question

Hello, 
this  the  code  doesn't  work    i  would   transpose  as  what  in existed  in  picture   the  result    from e:  h     i  hope  somebody  help me 
Sub VerticalToHorizontal()  Dim a As Variant, b As Variant  Dim RowsPerBlock As Long, NumBlocks As Long, i As Long, j As Long, BaseNum As Long    RowsPerBlock = Columns(1).Find(What:=Range("A1").Value, LookAt:=xlWhole).Row - 1    '*** RowsPerBlock will =1 if A1 is empty  or   '*** it will = 0 if A1 is the only cell in the column with data  If RowsPerBlock = 0 Or Range("A1") = "" Then    Exit Sub  End If  a = Range("B1:C" & Range("A" & Rows.Count).End(xlUp).Row).Value  NumBlocks = UBound(a) / RowsPerBlock  ReDim b(1 To NumBlocks, 1 To RowsPerBlock)  Do Until i = NumBlocks    i = i + 1    BaseNum = (i - 1) * RowsPerBlock    For j = 1 To RowsPerBlock      b(i, j) = a(BaseNum + j, 1)    Next j  Loop  With Range("e1").Resize(, RowsPerBlock)    .Value = Application.Transpose(Range("A1").Resize(RowsPerBlock).Value)    .Offset(1).Resize(NumBlocks).Value = b  End WithEnd Sub

TrowaD · Answer

Hi Abdel,

Your code doesn't make much sense to me.  RowsPerBlock will always be 0, since the value of A1 will always be found on the first row of the first column. And when it is 0, the code ends ....

So I took the liberty to write my own code. I hope you don't mind ;).

Here is the code:
Sub RunMe()
Dim lRow, lCol, x As Integer

lRow = Range("A1").End(xlDown).Row
lCol = Range("A1").End(xlToRight).Column

For Each cell In Range(Cells(1, 1), Cells(1, lCol))
    x = x + 1
    Range(Cells(1, cell.Column), Cells(lRow, cell.Column)).Copy
    Cells(x, lCol + 2).PasteSpecial Transpose:=True
Next cell
Application.CutCopyMode = False
End Sub

Best regards,
Trowa

TrowaD · Answer

Hi Abdel,

Ok, I added a line to clear the transposed data. When you want to add another column of data, right-click the empty column between original and transposed data (so column D for the first extra data column) and insert a column (to keep an empty column between original and transposed data), enter your data and run the code again to update (actually create new) the transposed data.

Here is the updated code:
Sub RunMe()
Dim lRow, lCol, x As Integer

lRow = Range("A1").End(xlDown).Row
lCol = Range("A1").End(xlToRight).Column

Cells(1, lCol + 2).CurrentRegion.ClearContents

For Each cell In Range(Cells(1, 1), Cells(1, lCol))
    x = x + 1
    Range(Cells(1, cell.Column), Cells(lRow, cell.Column)).Copy
    Cells(x, lCol + 2).PasteSpecial Transpose:=True
Next cell
Application.CutCopyMode = False
End Sub

PS: When you remove a column of data, you will want to run the code twice to get correct transposed data.

Best regards,
Trowa

Transpose data from vertical to horizontal

2 replies

Subscribe To Our Newsletter!