VBA Script Transpose Data

[Dave911]

Dear Experts,

Hoping you can help me

I would like to transpose data from one column into rows. I think there are about 4500 rows of data (not blank fields).

My data looks like below: 3 rows data, 1 blank row, 3 rows data, 1 blank row and then 3 rows of data. Further below you can see what the transposed version should look like. Can anyone help me to write a VBA script to solve this problem?

[TABLE="width: 261"]
<colgroup><col width="261" style="width: 196pt;"></colgroup><tbody>[TR]
[TD="width: 261"]Heineken[/TD]
[/TR]
[TR]
[TD]Positie in top 500: 10 (positie in 2017: 10)[/TD]
[/TR]
[TR]
[TD]Activiteit: Bierbrouwer[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Omzet 2017: 22.029 miljoen euro[/TD]
[/TR]
[TR]
[TD]Percentage + / - t.o.v. vorig jaar: 5,72%[/TD]
[/TR]
[TR]
[TD]Winst/verlies 2017: 2.153 miljoen euro[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Personeel: 80.000 [/TD]
[/TR]
[TR]
[TD]Percentage + / - t.o.v. vorig jaar: 9,38%[/TD]
[/TR]
[TR]
[TD]Vacatures 2018: 52[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Rabobank Groep[/TD]
[/TR]
[TR]
[TD]Positie in top 500: 11 (positie in 2017: 11)[/TD]
[/TR]
[TR]
[TD]Activiteit: Bank[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Omzet 2017: 21.125 miljoen euro[/TD]
[/TR]
[TR]
[TD]Percentage + / - t.o.v. vorig jaar: 1,76%[/TD]
[/TR]
[TR]
[TD]Winst/verlies 2017: 2.674 miljoen euro[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Personeel: 44.000 [/TD]
[/TR]
[TR]
[TD]Percentage + / - t.o.v. vorig jaar: -3,86%[/TD]
[/TR]
[TR]
[TD]Vacatures 2018: 128[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]SHV[/TD]
[/TR]
[TR]
[TD]Positie in top 500: 12 (positie in 2017: 13)[/TD]
[/TR]
[TR]
[TD]Activiteit: Energieconglomeraat[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Omzet 2017: 19.871 miljoen euro[/TD]
[/TR]
[TR]
[TD]Percentage + / - t.o.v. vorig jaar: 6,66%[/TD]
[/TR]
[TR]
[TD]Winst/verlies 2017: 1.264 miljoen euro[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Personeel: 60.000 [/TD]
[/TR]
[TR]
[TD]Percentage + / - t.o.v. vorig jaar: -0,33%[/TD]
[/TR]
[TR]
[TD]Vacatures 2018: 25[/TD]
[/TR]
</tbody>[/TABLE]


[TABLE="width: 1824"]
<colgroup><col width="139" style="width: 104pt;"><col width="264" style="width: 198pt;"><col width="221" style="width: 166pt;"><col width="139" style="width: 104pt;"><col width="227" style="width: 170pt;"><col width="139" span="6" style="width: 104pt;"></colgroup><tbody>[TR]
[TD="width: 139"]Shell[/TD]
[TD="width: 264"]Positie in top 500: 1 (positie in 2017: 1)[/TD]
[TD="width: 221"]Activiteit: Olie- en gasconcern[/TD]
[TD="width: 139"][/TD]
[TD="width: 227"]Omzet 2017: 281.680 miljoen euro[/TD]
[TD="width: 139"]Percentage + / - t.o.v. vorig jaar: 28,28%[/TD]
[TD="width: 278, colspan: 2"]Winst/verlies 2017: 12.401 miljoen euro[/TD]
[TD="width: 139"]Personeel: 86.000 [/TD]
[TD="width: 139"]Percentage + / - t.o.v. vorig jaar: -6,52%[/TD]
[TD="width: 139"]Vacatures 2018: 109[/TD]
[/TR]
[TR]
[TD]Vitol Holding [/TD]
[TD]Positie in top 500: 2 (positie in 2017: 2)[/TD]
[TD]Activiteit: Oliehandel[/TD]
[TD][/TD]
[TD]Omzet 2017: 143.842 miljoen euro[/TD]
[TD]Percentage + / - t.o.v. vorig jaar: -6,67%[/TD]
[TD="colspan: 2"]Winst/verlies 2017: 1.975 miljoen euro[/TD]
[TD]Personeel: 2.200 [/TD]
[TD]Percentage + / - t.o.v. vorig jaar: 21,55%[/TD]
[TD]Vacatures 2018: 0[/TD]
[/TR]
[TR]
[TD]Ahold Delhaize[/TD]
[TD]Positie in top 500: 3 (positie in 2017: 4)[/TD]
[TD]Activiteit: Supermarktketen[/TD]
[TD][/TD]
[TD]Omzet 2017: 62.890 miljoen euro[/TD]
[TD]Percentage + / - t.o.v. vorig jaar: 26,55%[/TD]
[TD="colspan: 2"]Winst/verlies 2017: 1.817 miljoen euro[/TD]
[TD]Personeel: 369.000 [/TD]
[TD]Percentage + / - t.o.v. vorig jaar: -0,27%[/TD]
[TD]Vacatures 2018: 3218[/TD]
[/TR]
[TR]
[TD]Aegon[/TD]
[TD]Positie in top 500: 4 (positie in 2017: 7)[/TD]
[TD]Activiteit: Verzekeraar[/TD]
[TD][/TD]
[TD]Omzet 2017: 57.910 miljoen euro[/TD]
[TD]Percentage + / - t.o.v. vorig jaar: 8,53%[/TD]
[TD="colspan: 2"]Winst/verlies 2017: 2.361 miljoen euro[/TD]
[TD]Personeel: 28.000 [/TD]
[TD]Percentage + / - t.o.v. vorig jaar: -3,61%[/TD]
[TD]Vacatures 2018: 92[/TD]
[/TR]
[TR]
[TD]Unilever[/TD]
[TD]Positie in top 500: 5 (positie in 2017: 3)[/TD]
[TD]Activiteit: Levensmiddelenfabrikant[/TD]
[TD][/TD]
[TD]Omzet 2017: 53.715 miljoen euro[/TD]
[TD]Percentage + / - t.o.v. vorig jaar: 1,9%[/TD]
[TD="colspan: 2"]Winst/verlies 2017: 6.486 miljoen euro[/TD]
[TD]Personeel: 161.000 [/TD]
[TD]Percentage + / - t.o.v. vorig jaar: -4,73%[/TD]
[TD]Vacatures 2018: 27[/TD]
[/TR]
[TR]
[TD]ING[/TD]
[TD]Positie in top 500: 6 (positie in 2017: 5)[/TD]
[TD]Activiteit: Bank[/TD]
[TD][/TD]
[TD]Omzet 2017: 48.017 miljoen euro[/TD]
[TD]Percentage + / - t.o.v. vorig jaar: -3,15%[/TD]
[TD="colspan: 2"]Winst/verlies 2017: 4.987 miljoen euro[/TD]
[TD]Personeel: 58.000 [/TD]
[TD]Percentage + / - t.o.v. vorig jaar: 10,8%[/TD]
[TD]Vacatures 2018: 259[/TD]
[/TR]
[TR]
[TD]Ingka Holding (IKEA)[/TD]
[TD]Positie in top 500: 7 (positie in 2017: 6)[/TD]
[TD]Activiteit: Meubelwarenhuisketen[/TD]
[TD][/TD]
[TD]Omzet 2017: 36.602 miljoen euro[/TD]
[TD]Percentage + / - t.o.v. vorig jaar: 3,27%[/TD]
[TD="colspan: 2"]Winst/verlies 2017: 2.505 miljoen euro[/TD]
[TD]Personeel: 155.000 [/TD]
[TD]Percentage + / - t.o.v. vorig jaar: n.b.%[/TD]
[TD]Vacatures 2018: 57[/TD]
[/TR]
[TR]
[TD]Randstad[/TD]
[TD]Positie in top 500: 8 (positie in 2017: 12)[/TD]
[TD]Activiteit: Uitzendbureau[/TD]
[TD][/TD]
[TD]Omzet 2017: 23.273 miljoen euro[/TD]
[TD]Percentage + / - t.o.v. vorig jaar: 12,52%[/TD]
[TD="colspan: 2"]Winst/verlies 2017: 632 miljoen euro[/TD]
[TD]Personeel: 38.000 [/TD]
[TD]Percentage + / - t.o.v. vorig jaar: 17,5%[/TD]
[TD]Vacatures 2018: 3578[/TD]
[/TR]
[TR]
[TD]Achmea[/TD]
[TD]Positie in top 500: 9 (positie in 2017: 8)[/TD]
[TD]Activiteit: Verzekeraar[/TD]
[TD][/TD]
[TD]Omzet 2017: 22.065 miljoen euro[/TD]
[TD]Percentage + / - t.o.v. vorig jaar: -8,01%[/TD]
[TD="colspan: 2"]Winst/verlies 2017: 216 miljoen euro[/TD]
[TD]Personeel: 15.000 [/TD]
[TD]Percentage + / - t.o.v. vorig jaar: -2,27%[/TD]
[TD]Vacatures 2018: 89[/TD]
[/TR]
</tbody>[/TABLE]


Thanks,

Dave from Holland

 

[Fluff]

Hi & welcome to MrExcel.
In you description you say that there are 3rows of data followed by a blank row, yet the data you have posted looks like 9 rows of data with a blank.
Could you please confirm which is correct? If it is 3 rows can you confirm which data is in the same cell?

 

[Dave911]

Sorry my cut and paste effort has destroyed how the date looks in Excel. It should be like this.

Row1 data
Row2 data
Row3 data
Blank Row 4
Row5 data
Row6 data
Row7 data
Blank Row 8
Row 9 data
Row 10 data
Row 11 data

This is one record which should be transposed to one row

Then there are 3 blank rows and data starts again

Row 15
Row 16 etc..

Each Row contains data in one cell.

So transposed data should look like:

Column 1 data, Col 2 data, col 3 data, blank col 4, col 5 data, col 6 data, col 7 data, col 8 blank, col 9 data, col 10 data, col 11 data
[TABLE="width: 1772"]
<colgroup><col width="264" style="width: 198pt;"><col width="221" style="width: 166pt;"><col width="139" style="width: 104pt;"><col width="227" style="width: 170pt;"><col width="139" span="6" style="width: 104pt;"><col width="87" style="width: 65pt;"></colgroup><tbody></tbody>[/TABLE]

Hi & welcome to MrExcel.
In you description you say that there are 3rows of data followed by a blank row, yet the data you have posted looks like 9 rows of data with a blank.
Could you please confirm which is correct? If it is 3 rows can you confirm which data is in the same cell?

 

[Fluff]

Ok, how about

Sub Dave911()
   Dim Ary As Variant, Nary As Variant
   Dim i As Long, j As Long, nr As Long, nc As Long
   
   Ary = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value2
   ReDim Nary(1 To UBound(Ary), 1 To 9)
   For i = 1 To UBound(Ary) Step 14
      nr = nr + 1
      For j = i To i + 13
         If j > UBound(Ary) Then Exit For
         If Ary(j, 1) <> "" Then
            nc = nc + 1
            Nary(nr, nc) = Ary(j, 1)
         End If
      Next j
      nc = 0
   Next i
   Range("B1").Resize(nr, 9).Value = Nary
End Sub

 

[Fluff]

Scrub that, just realised you want to keep the blanks, try

Sub Dave911()
   Dim Ary As Variant, Nary As Variant
   Dim i As Long, j As Long, nr As Long, nc As Long
   
   Ary = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value2
   ReDim Nary(1 To UBound(Ary), 1 To 11)
   For i = 1 To UBound(Ary) Step 14
      nr = nr + 1
      For j = i To i + 10
         nc = nc + 1
         Nary(nr, nc) = Ary(j, 1)
      Next j
      nc = 0
   Next i
   Range("B1").Resize(nr, 11).Value = Nary
End Sub

 

[Dave911]

Sub Dave911()   Dim Ary As Variant, Nary As Variant   Dim i As Long, j As Long, nr As Long, nc As Long      Ary = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value2   ReDim Nary(1 To UBound(Ary), 1 To 9)   For i = 1 To UBound(Ary) Step 14      nr = nr + 1      For j = i To i + 13         If j > UBound(Ary) Then Exit For         If Ary(j, 1) <> "" Then            nc = nc + 1            Nary(nr, nc) = Ary(j, 1)         End If      Next j      nc = 0   Next i   Range("B1").Resize(nr, 9).Value = NaryEnd Sub

Thanks for the solution, however, I am getting an error "Run time error 9 subscript out of range'

It seems to work with the first 3 records, but with more there. is an error.

Do you know want the issue is? is it better to delete the blank lines?

Dave

Ok, how about

Sub Dave911()   Dim Ary As Variant, Nary As Variant   Dim i As Long, j As Long, nr As Long, nc As Long      Ary = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value2   ReDim Nary(1 To UBound(Ary), 1 To 9)   For i = 1 To UBound(Ary) Step 14      nr = nr + 1      For j = i To i + 13         If j > UBound(Ary) Then Exit For         If Ary(j, 1) <> "" Then            nc = nc + 1            Nary(nr, nc) = Ary(j, 1)         End If      Next j      nc = 0   Next i   Range("B1").Resize(nr, 9).Value = NaryEnd Sub

 

[Dave911]

Thanks the code works perfectly. Your help is really appreciated. We can mark this as solved

 

[Fluff]

You're welcome & thanks for the feedback.