Transformation of data with macro

[kaninvalp]

Hi,
I need a macro to be able to transform some data from one layout/format to another.
Please see attached sheet. The original data is stored like in sheet "Original Fileformat" (this is the input)
I need to reorganize the data so the output is like in sheet "New Fileformat"
C12345 = Customer Code
1111111 - 9999999 = Products
Dates in row 1
and C2:BB10 are volumes.
Amount of products should not be limited to 9 products as in this example file.

Thanks!
15285

[JKwan]

give this a try, limited testing

Option Explicit
Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
FindLastRow = WS.Range(ColumnLetter & Rows.Count).End(xlUp).Row
End Function

Function FindLastColumn(ByVal WS As Worksheet, lRow As Long) As Long
FindLastColumn = WS.Cells(lRow, Columns.Count).End(xlToLeft).Column
End Function

Sub TransformLayout()
Dim LastRow As Long
Dim LastCol As Long
Dim lRow As Long
Dim lCol As Long
Dim WSOutLastRow As Long

Dim WSInput As Worksheet
Dim WSOut As Worksheet

Set WSInput = Worksheets("Original Fileformat")
Set WSOut = Worksheets.Add(After:=Worksheets(Worksheets.Count))
WSOut.Name = "New"

LastRow = FindLastRow(WSInput, "A")
LastCol = FindLastColumn(WSInput, 1)
WSOutLastRow = 1
With WSOut
For lRow = 2 To LastRow
For lCol = 3 To LastCol
.Cells(WSOutLastRow, 1) = WSInput.Cells(lRow, "A")
.Cells(WSOutLastRow, 2) = WSInput.Cells(lRow, "B")
.Cells(WSOutLastRow, 3) = WSInput.Cells(1, lCol)
.Cells(WSOutLastRow, 4) = WSInput.Cells(lRow, lCol)

WSOutLastRow = WSOutLastRow + 1
Next lCol
Next lRow
End With
Set WSInput = Nothing
Set WSOut = Nothing
End Sub

[SamT]

Are there more than one customer codes?

This is an xlsx Book. The code need to go in an xlsm book.

Will you be transforming this book into an xlsm, or will the code go in a different Book?

The attachment is an xlsm file. The code will need a bit of variable assignment editing. It is a brute force code, and it takes about .5 second to run. There are faster ways, but they will probably use the same algorithm or one very close to it.

15289

Can somebody say why I get an intermittent error when setting DateRng?
Option Explicit

Sub VBAX_kaninvalp()
Dim SrcSht As Worksheet
Dim DateRng As Range
Dim DestSht As Worksheet
Dim DestCel As Range
Dim Cel As Range

Set SrcSht = ThisWorkbook.Sheets("Original Fileformat") 'edit as needed
Set DestSht = ThisWorkbook.Sheets("Sheet1") 'edit as needed

Set DateRng = SrcSht.Range(Cells(1, 3), Cells(1, Columns.Count).End(xlToLeft))

Application.ScreenUpdating = False

For Each Cel In SrcSht.Range(Cells(2, 2), Cells(2, 2).End(xlDown)).Cells
Set DestCel = DestSht.Cells(Rows.Count, 3).End(xlUp)

'Customer to A, Product to B
DestCel.Offset(, -2) = Cel.Offset(, -1)
DestCel.Offset(, -1) = Cel

'Dates to C
DateRng.Copy
DestCel.PasteSpecial Transpose:=True

'Values to D
Range(Cel, Cel.End(xlToRight)).Copy
DestCel.Offset(, 1).PasteSpecial Transpose:=True

Range(DestCel, DestCel.End(xlDown)).Offset(, -2).FillDown
Range(DestCel, DestCel.End(xlDown)).Offset(, -1).FillDown
Next Cel

GracefulExit:
Set Cel = Nothing
Set DateRng = Nothing
Application.ScreenUpdating = True
End Sub

[kaninvalp]

Seems to work excellent.
Thanks!

[snb]

or

Sub M_snb()
sn = Sheet1.Cells(1).CurrentRegion
ReDim sp((UBound(sn) - 1) * (UBound(sn, 2) - 2) - 1, 3)

For j = 0 To UBound(sp)
x = j \ (UBound(sn, 2) - 2) + 2
y = j Mod (UBound(sn, 2) - 2) + 3

sp(j, 0) = sn(x, 1)
sp(j, 1) = sn(x, 2)
sp(j, 2) = sn(1, y)
sp(j, 3) = sn(x, y)
Next

Sheet2.Cells(1, 10).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp
End Sub