VBA needed to reformat data

[blkane]

Existing Data
	600950	600951	600952	600953	600954
A	15			15000	300
B		200	1000		100
C	25		75		50
D	100		22		500
E		5000	80
F		750	15		600
G		100		1000	25

<tbody>
</tbody>

Hi,

Would someone help me write a VBA script to reformat data? The existing data is structure with a data element in the header row.

I need to format everything in simple columns COL1 Row 1 would be "A" Col2 Row 1 would be 600950 and Col3 Row 1 would be 15, etc..



Thank you
Brenda

 

[alansidman]

Brenda,
I am a bit confused. Please show an expected results of the reformat so that we can provide exactly what you need.

 

[blkane]

Brenda,
I am a bit confused. Please show an expected results of the reformat so that we can provide exactly what you need.

My apologies.

column 1	column2	column3
A	600950	15
A	600951	0
A	600952	0
A	600953	15000
A	600954	300
B	600950	0
B	600951	200
B	600952	1000
B	600953	0
B	600954	100
ETC....

<tbody>
</tbody>

 

[alansidman]

Option Explicit


Sub Brenda()
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Sheet3") 'change to your sheet name
    Set s2 = Sheets("Sheet4") 'change to your sheet name
    Dim lr As Long, lc As Long
    Dim i As Long, lr2 As Long
    Application.ScreenUpdating = False
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    lc = s1.Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 2 To lr
        lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row
        s1.Range("A" & i).Copy s2.Range("A" & lr2 + 1)
        s1.Range(Cells(1, 2), Cells(1, lc)).Copy
        s2.Range("B" & lr2 + 1).PasteSpecial xlPasteValues, , , True
        s1.Range(Cells(i, 2), Cells(i, lc)).Copy
        s2.Range("C" & lr2 + 1).PasteSpecial xlPasteValues, , , True
    Next i
    lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row
    For i = 3 To lr2
        If s2.Range("A" & i) = "" Then s2.Range("A" & i) = s2.Range("A" & i - 1)
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Action Complete"
End Sub

 

[blkane]

Thank you!

 

[tonyyy]

Another approach to consider...

Sub AnotherReformat_1066838()
Dim arr1 As Variant, arr2 As Variant
Dim lastRow As Long, lastCol As Long, r As Long, c As Long, n As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

arr1 = Range(Cells(1, 1), Cells(lastRow, lastCol)).Value
ReDim arr2(1 To ((lastRow - 1) * (lastCol - 1)), 1 To 3)
n = 1
For r = 2 To UBound(arr1)
    For c = 2 To UBound(arr1, 2)
        arr2(n, 1) = arr1(r, 1)
        arr2(n, 2) = arr1(1, c)
        arr2(n, 3) = arr1(r, c)
        n = n + 1
    Next c
Next r
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1:C" & ((lastRow - 1) * (lastCol - 1))).Value = arr2
End Sub

Cheers,

tonyyy