VBA code to Transpose from one column to multiple columns

[peppe1985]

Hello all, I'm still fairly new to VBA and I'm at a lost how in can transpose data that I have in spreadsheet to multiple columns while deleting blank rows in between.

Attached are 2 images, the original sheet of how my data looks, the second sheet is what I'm looking to get as a final outcome.

Any help would be greatly appreciated

Thanks

 

[DanteAmor]

Your data on sheet1, starting in cell A2. The results on sheet2.

Try:

Sub TransposeColumn()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, n As Long
  Dim ar As Range
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  
  sh2.Cells.ClearContents
  i = 2
  For Each ar In sh1.Range("A2:A" & sh1.Range("F" & Rows.Count).End(3).Row).SpecialCells(xlCellTypeBlanks).Areas
    n = ar.Rows.Count
    sh2.Range("A" & i).Resize(1, 6).Value = ar.Offset(-1).Resize(1, 6).Value
    sh2.Range("G" & i).Resize(1, n).Value = Application.Transpose(ar.Offset(0, 5).Value)
    i = i + 1
  Next
End Sub

 

[Ezguy4u]

peppe because you can never have too many solutions to a problem, here is another one. I would like to say there are many more solutions to this problem and I will continue to tweek my program. Sometimes the A plus students weigh in and get the same answer with 2 lines of code. Anyway if you have questions, comments or suggestions let us know.

Option Explicit

Sub TransposeColumn()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, n As Long
  Dim LastRow As Long
  Dim Row1 As Long
  Dim Row2 As Long
  Dim Count1 As Long
  Dim Count2 As Long
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  
    sh2.Cells.ClearContents
    Row2 = 2
    Count2 = 1
 
sh1.Select
LastRow = Cells(Rows.Count, "G").End(xlUp).Row

Row1 = LastRow
Count1 = Cells(LastRow, 7)
Range("A" & LastRow - Count1, "F" & LastRow - Count1).Select
Selection.Copy
    Sheets("Sheet2").Select
    Sheets("Sheet2").Range("A2").Select
    ActiveSheet.Paste
For n = 7 To Count1 + 6
    Sheets("Sheet2").Cells(Row2, n).Select
    Sheets("Sheet2").Cells(Row2, n) = Count2
    Count2 = Count2 + 1
Next n

Count2 = 1
sh1.Select

Do Until ActiveCell.Address = sh1.Range("A2").Address

Cells(LastRow, 7).Select
Count1 = Cells(LastRow, 7)

For i = LastRow To Count1 Step -1

If Cells(LastRow, 7) = "" Then

LastRow = LastRow - 1
Count1 = Cells(LastRow, 7)

sh2.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Row1 = LastRow
Count1 = Cells(LastRow, 7)
Range("A" & LastRow - Count1, "F" & LastRow - Count1).Select
Selection.Copy
    Sheets("Sheet2").Select
    Sheets("Sheet2").Range("A2").Select
    ActiveSheet.Paste
For n = 7 To Count1 + 6
    Sheets("Sheet2").Cells(Row2, n).Select
    Sheets("Sheet2").Cells(Row2, n) = Count2
    Count2 = Count2 + 1
Next n

Count2 = 1
sh1.Select
Exit For

Else

Cells(LastRow, 7).Select
LastRow = LastRow - 1

End If

Next i

Loop

sh2.Select
sh2.Range("A1").Select
sh1.Select
Range("A1").Select
Application.CutCopyMode = False

End Sub

22-11-25 working 7.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1
2	Number	Text	0	Name 1	11/24/2022	Description	1	2	3	4	5	6	7	8	9	10
3	Number	Text	0	Name 2	11/24/2022	Description	1	2	3
4	Number	Text	0	Name 3	11/24/2022	Description	1	2	3	4	5
5	Number	Text	0	Name 4	11/24/2022	Description	1	2	3	4
6	Number	Text	0	Name 5	11/24/2022	Description	1	2	3	4	5
Sheet2

22-11-25 working 7.xlsm
	A	B	C	D	E	F	G
1
2	Number	Text	0	Name 1	11/24/2022	Description
3							1
4							2
5							3
6							4
7							5
8							6
9							7
10							8
11							9
12							10
13	Number	Text	0	Name 2	11/24/2022	Description
14							1
15							2
16							3
17	Number	Text	0	Name 3	11/24/2022	Description
18							1
19							2
20							3
21							4
22							5
23	Number	Text	0	Name 4	11/24/2022	Description
24							1
25							2
26							3
27							4
28	Number	Text	0	Name 5	11/24/2022	Description
29							1
30							2
31							3
32							4
33							5
Sheet1

 

[Peter_SSs]

Perhaps I'm wrong but reading of "deleting blank rows" makes me think the two sheets reference was for sample results only and that the requirement is for a single sheet.
If that is so and in ..
- column F the descriptions are all text and the numbers are not text numbers and not the result of formulas,
- column A the cells that appear blank are in fact empty
.. then you could try this with a copy of your workbook.

BTW, I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with. It will usually get you faster and better responses.

Sub Rearrange()
  Dim rA As Range
  
  Application.ScreenUpdating = False
  For Each rA In Columns("F").SpecialCells(xlConstants, xlNumbers).Areas
    rA.Offset(-1, 1).Resize(1, rA.Rows.Count).Value = Application.Transpose(rA.Value)
  Next rA
  Columns("F").SpecialCells(xlConstants, xlNumbers).EntireRow.Delete
  Application.ScreenUpdating = True
End Sub

 

[peppe1985]

Thanks everyone. They all worked great . Appreciate the help

 

[Peter_SSs]

You're welcome. Glad we could help. Thanks for letting us know.