Multiple Columns into 2 Columns

Hi all,

I am looking for help so that a tedious becomes quick and fun.

In a worksheet I have data which has been submitted as follow:

Rep Dealer Div SKU Period1 Period2 Perdiod3 Period4
Bob 1234 AA SKU1 2 0 0 2
Bob 1234 AA SKU2 2 2 0 2
Bob 1234 AA SKU3 1 0 2 0
Bob 1234 AA SKU4 2 2 1 0

My desired outcome would be:

Rep Dealer Div SKU Period QTY
Bob 1234 AA SKU1 Period1 2
Bob 1234 AA SKU1 Period2 0
Bob 1234 AA SKU1 Period3 0
Bob 1234 AA SKU1 Period4 2
Bob 1234 AA SKU2 Period1 2
Bob 1234 AA SKU2 Period2 2
Bob 1234 AA SKU2 Period3 0
Bob 1234 AA SKU2 Period4 2

Essentially flattening out the data so that It can be used in a Access and PowerPivot.

Is there a way to do this in VBA? Note that my knowledge of VBA is Freshman level.

Thanks in advance for your help,

Guillaume

 

Question Info


Last updated February 24, 2018 Views 72 Applies to:
Answer
Answer

Hi,

assuming that data is on Sheet1 (change name as needed)

expected results in a new sheet

now,

step1

take a look here...

https://www.youtube.com/watch?v=vtTa8y6i_rM

step2

Save As, your Workbook with extension .xlsm (macros enabled)

step3

3.1) press ALT+F11 to open Visual Basic

3.2) on the ribbon, select: Insert > module and paste the code below on the right

[edit..]

Sub ConvertData()

'Mar 17, 2015

Const N As Long = 2 '<<< data starts in row 2
Const c As Long = 4 '<<number of periods
Dim ws As Worksheet
Set ws = Sheets("Sheet1") '<< source sheet name, change
Dim r As Long, x As Long, t As Long
r = ws.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Sheets.Add
ws.Range("A1:D1").Copy

[A1].PasteSpecial xlPasteValues

[E1].Value = "Period"
[F1].Value = "Qty"
t = 2
For x = N To r
ws.Cells(x, "A").Copy
Cells(t, "A").Resize(c).PasteSpecial xlPasteValues
ws.Cells(x, "B").Resize(, 3).Copy
Cells(t, "B").Resize(c).PasteSpecial xlPasteValues
ws.Cells(1, "E").Resize(, c).Copy
Cells(t, "E").PasteSpecial xlPasteValues, Transpose:=True
ws.Cells(x, "E").Resize(, c).Copy
Cells(t, "F").PasteSpecial xlPasteValues, Transpose:=True
t = Cells(Rows.Count, "A").End(xlUp).Row + 1
Next
Application.CutCopyMode = False
[A1].Select
ActiveSheet.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

3.3) Press ALT+Q to Close Visual Basic

step4

To run the macro, press ALT+F8, 

select: ConvertData from the list and click the run button.

or

add a button and assign the vba macro

-----------------------------
Office 365 on Windows 10

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.