Transposing data using VBA

Mr2017

Well-known Member
Joined
Nov 28, 2016
Messages
634
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi

I have some data in a Summary sheet which starts in column J and goes up to column AY in a Sheet.

Below is a small sample - just 9 columns and three rows.

The data is in blocks of three different columns ("Location & Dist", "Platform", and "Percentage") - please ignore the numbers, as this is random data. Is there a better way to transpose this data into one column? At present, the code I have only copies specific columns, but the number of columns could change in a future file. So I was wondering how to take that into account? ie is there a way of getting the code to continue copying three blocks of data until it reaches a blank column?

Location & DistPlatform: CPercentageLocation & DistPlatform: PMPercentageLocation & DistPlatform: SPercentage
Address 1Plt: C
$20,591.00​
0%Address 1Plt: PM
$29,787.00​
0%Address 1Plt: S
$72,763.00​
0%
Address 2Plt: C
$23,003.00​
0%Address 2Plt: PM
$92,523.00​
0%Address 2Plt: S
$71,299.00​
0%
Address 3Plt: C
$82,273.00​
0%Address 3Plt: PM
$14,975.00​
0%Address 3Plt: S
$87,301.00​
0%


My current process is this:

Go to Sheet 24 (the Summary sheet) copy the block of data in columns J to L, then go to cell A1 in Sheet 1 and paste it. It then covers columns A-C in Sheet 1.

Go back to Sheet 24 (the Summary sheet), copy the next block of data in columns M to O, then go to the bottom of the range of data pasted in Sheet 1 and paste the newly acquired data there.



I'd be grateful for any thoughts? My code is below - I've left in the code that copies columns beyond the number shown above, as the actual file has more columns. But I'd like the code to stop, if I only have 9 columns, or keep on going, if I have more. Please let me know if you want me to clarify anthing. Thanks in advance

VBA Code:
Sub GetPercentageData()

'Sheet24 in the code below is the Summary Sheet
'Sheet 1 is the transposing sheet, where I am pasting data that's in multiple columns in Sheet 24 (the Summary Sheet)
'into one column in the transposing sheet.

'first clear the sheet with the existing percentage data

Sheet1.Activate

Range("A1").CurrentRegion.Select

Selection.ClearContents
Selection.ClearFormats

'then go to the Summary sheet with the percentage data

Sheet24.Activate

'copy the data from the first group in columns J:L.

Range("J15", Range("L15").End(xlDown)).Copy

'paste their unique ID codes and percentage data into your 'transposing' sheet

Sheet1.Activate

Range("A1").PasteSpecial xlPasteValues

'go back to the Summary Sheet (Sheet24) and get the next set of percentage data

Sheet24.Activate

Range("M15", Range("O15").End(xlDown)).Copy

'go to the transposing sheet

Sheet1.Activate
'go to the bottom of the range in Sheet 1 and paste in the newly acquired data

Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

'back to the Summary sheet

Sheet24.Activate

Range("P15", Range("R15").End(xlDown)).Copy

'transposing sheet

Sheet1.Activate
'go to the bottom of the range in Sheet 1 and paste in the newly acquired data

Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues


End Sub
 

Some videos you may like

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows
try this code:
VBA Code:
Sub test()
Dim outarr()
With Worksheets("Sheet24")
lastrow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
lastcolumn = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
 inarr = .Range(.Cells(1, 1), .Cells(lastrow, lastcolumn))
End With
With Worksheets("Sheet1")
lastout = (1 + Round((lastcolumn / 3))) * lastrow
ReDim outarr(1 To lastout, 1 To 3)
indi = 1
For i = 10 To UBound(inarr, 2) Step 3
   For j = 1 To UBound(inarr, 1)
    For k = 0 To 2
       outarr(indi, k + 1) = inarr(j, i + k)
    Next k
    indi = indi + 1
   Next j
Next i
 Range(.Cells(1, 1), .Cells(indi, 3)) = outarr
 
End With
End Sub
 

Mr2017

Well-known Member
Joined
Nov 28, 2016
Messages
634
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi @offtheflip

Thanks for the prompt response!

I tried to run the code, but it gave me a "run time error: 9 (subscript out of range)" message when it got to this line:

outarr(indi, k + 1) = inarr(j, i + k)

Do you know why that may be?

Thanks in advance.
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows
try changning this line:
VBA Code:
For i = 10 To UBound(inarr, 2) Step 3

to
VBA Code:
For i = 10 To UBound(inarr, 2)-3 Step 3
 

Mr2017

Well-known Member
Joined
Nov 28, 2016
Messages
634
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

Thanks.

That made it run successfully.

However, some columns of data weren't together correctly, at the end?

Eg these columns were grouped together.

But they should have had a "Location & Dist." column, as well as a "Package" column, in between them

Plt: SBBPlt: EclipsePlt: PIRA Dimensions
0.000302​
0​
0​
0​
0​
0.000238​
0​
0​
0​
0.08406​
0​
0.087886​
0.001913​
0​
0​
0​
0​
0.000238​
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows
the code works by grabbing 3 columns and pasting them below the last paste, it doesn't concern it self with the contents. it reliably grabs 3 columns so if the result is not what you want it is because the data doesn't quite match what you are expecting. Can you paste the header row of the data you are using to forum??
 

Mr2017

Well-known Member
Joined
Nov 28, 2016
Messages
634
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

Aha! You were right! Apologies!

There were some additional columns at the end of the file that I hadn't noticed before.

I thought that the code would stop when it got to a a blank column. But it carried on. If you know of a way to make it stop when it reaches a blank column, please let me know.

If not, don't worry.

Thanks for your help with this!
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows
You could try adding this line after the i loop control:
VBA Code:
For i = 10 To UBound(inarr, 2)-3 Step 3
if inarr(1,i)="" then Exit for
thatwill catch a blank line in Loc & Dist column , but doesn't detect it in the others. see if that if good enough
 

Mr2017

Well-known Member
Joined
Nov 28, 2016
Messages
634
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Ok, thanks - I'll try that tomorrow. Just in the middle of debugging some other code!
 

Watch MrExcel Video

Forum statistics

Threads
1,114,528
Messages
5,548,571
Members
410,852
Latest member
WernerS
Top