VBA Script Transpose Data

Dave911

New Member
Joined
Sep 12, 2019
Messages
4
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?

Heineken
Positie in top 500: 10 (positie in 2017: 10)
Activiteit: Bierbrouwer
Omzet 2017: 22.029 miljoen euro
Percentage + / - t.o.v. vorig jaar: 5,72%
Winst/verlies 2017: 2.153 miljoen euro
Personeel: 80.000
Percentage + / - t.o.v. vorig jaar: 9,38%
Vacatures 2018: 52
Rabobank Groep
Positie in top 500: 11 (positie in 2017: 11)
Activiteit: Bank
Omzet 2017: 21.125 miljoen euro
Percentage + / - t.o.v. vorig jaar: 1,76%
Winst/verlies 2017: 2.674 miljoen euro
Personeel: 44.000
Percentage + / - t.o.v. vorig jaar: -3,86%
Vacatures 2018: 128
SHV
Positie in top 500: 12 (positie in 2017: 13)
Activiteit: Energieconglomeraat
Omzet 2017: 19.871 miljoen euro
Percentage + / - t.o.v. vorig jaar: 6,66%
Winst/verlies 2017: 1.264 miljoen euro
Personeel: 60.000
Percentage + / - t.o.v. vorig jaar: -0,33%
Vacatures 2018: 25

<colgroup><col width="261" style="width: 196pt;"></colgroup><tbody>
</tbody>


ShellPositie in top 500: 1 (positie in 2017: 1)Activiteit: Olie- en gasconcernOmzet 2017: 281.680 miljoen euroPercentage + / - t.o.v. vorig jaar: 28,28%Winst/verlies 2017: 12.401 miljoen euroPersoneel: 86.000 Percentage + / - t.o.v. vorig jaar: -6,52%Vacatures 2018: 109
Vitol Holding Positie in top 500: 2 (positie in 2017: 2)Activiteit: OliehandelOmzet 2017: 143.842 miljoen euroPercentage + / - t.o.v. vorig jaar: -6,67%Winst/verlies 2017: 1.975 miljoen euroPersoneel: 2.200 Percentage + / - t.o.v. vorig jaar: 21,55%Vacatures 2018: 0
Ahold DelhaizePositie in top 500: 3 (positie in 2017: 4)Activiteit: SupermarktketenOmzet 2017: 62.890 miljoen euroPercentage + / - t.o.v. vorig jaar: 26,55%Winst/verlies 2017: 1.817 miljoen euroPersoneel: 369.000 Percentage + / - t.o.v. vorig jaar: -0,27%Vacatures 2018: 3218
AegonPositie in top 500: 4 (positie in 2017: 7)Activiteit: VerzekeraarOmzet 2017: 57.910 miljoen euroPercentage + / - t.o.v. vorig jaar: 8,53%Winst/verlies 2017: 2.361 miljoen euroPersoneel: 28.000 Percentage + / - t.o.v. vorig jaar: -3,61%Vacatures 2018: 92
UnileverPositie in top 500: 5 (positie in 2017: 3)Activiteit: LevensmiddelenfabrikantOmzet 2017: 53.715 miljoen euroPercentage + / - t.o.v. vorig jaar: 1,9%Winst/verlies 2017: 6.486 miljoen euroPersoneel: 161.000 Percentage + / - t.o.v. vorig jaar: -4,73%Vacatures 2018: 27
INGPositie in top 500: 6 (positie in 2017: 5)Activiteit: BankOmzet 2017: 48.017 miljoen euroPercentage + / - t.o.v. vorig jaar: -3,15%Winst/verlies 2017: 4.987 miljoen euroPersoneel: 58.000 Percentage + / - t.o.v. vorig jaar: 10,8%Vacatures 2018: 259
Ingka Holding (IKEA)Positie in top 500: 7 (positie in 2017: 6)Activiteit: MeubelwarenhuisketenOmzet 2017: 36.602 miljoen euroPercentage + / - t.o.v. vorig jaar: 3,27%Winst/verlies 2017: 2.505 miljoen euroPersoneel: 155.000 Percentage + / - t.o.v. vorig jaar: n.b.%Vacatures 2018: 57
RandstadPositie in top 500: 8 (positie in 2017: 12)Activiteit: UitzendbureauOmzet 2017: 23.273 miljoen euroPercentage + / - t.o.v. vorig jaar: 12,52%Winst/verlies 2017: 632 miljoen euroPersoneel: 38.000 Percentage + / - t.o.v. vorig jaar: 17,5%Vacatures 2018: 3578
AchmeaPositie in top 500: 9 (positie in 2017: 8)Activiteit: VerzekeraarOmzet 2017: 22.065 miljoen euroPercentage + / - t.o.v. vorig jaar: -8,01%Winst/verlies 2017: 216 miljoen euroPersoneel: 15.000 Percentage + / - t.o.v. vorig jaar: -2,27%Vacatures 2018: 89

<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>
</tbody>


Thanks,

Dave from Holland
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
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?
 
Upvote 0
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

<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>








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?
 
Upvote 0
Ok, how about
Code:
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
 
Upvote 0
Scrub that, just realised you want to keep the blanks, try
Code:
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
 
Upvote 0
HTML:
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
Code:
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
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,287
Members
448,562
Latest member
Flashbond

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top