VBA needed to reformat data

[blkane]

[TABLE="width: 500"]
<tbody>[TR]
[TD]Existing Data
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD="align: center"]600950

[/TD]
[TD="align: center"]600951

[/TD]
[TD="align: center"]600952

[/TD]
[TD="align: center"]600953

[/TD]
[TD="align: center"]600954
[/TD]
[/TR]
[TR]
[TD="align: center"]A
[/TD]
[TD="align: center"]15
[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"]15000
[/TD]
[TD="align: center"]300
[/TD]
[/TR]
[TR]
[TD="align: center"]B
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]200
[/TD]
[TD="align: center"]1000
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]100
[/TD]
[/TR]
[TR]
[TD="align: center"]C
[/TD]
[TD="align: center"]25
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]75
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]50
[/TD]
[/TR]
[TR]
[TD="align: center"]D
[/TD]
[TD="align: center"]100
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]22
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]500
[/TD]
[/TR]
[TR]
[TD="align: center"]E
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]5000
[/TD]
[TD="align: center"]80
[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]F
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]750
[/TD]
[TD="align: center"]15
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]600
[/TD]
[/TR]
[TR]
[TD="align: center"]G
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]100
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]1000
[/TD]
[TD="align: center"]25
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
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.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD="align: center"]column 1[/TD]
[TD="align: center"]column2[/TD]
[TD="align: center"]column3[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]600950[/TD]
[TD="align: right"]15[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]600951[/TD]
[TD="align: right"]0[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]600952[/TD]
[TD="align: right"]0[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]600953[/TD]
[TD="align: right"]15000[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]600954[/TD]
[TD="align: right"]300[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]600950[/TD]
[TD="align: right"]0[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]600951[/TD]
[TD="align: right"]200[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]600952[/TD]
[TD="align: right"]1000[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]600953[/TD]
[TD="align: right"]0[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]600954[/TD]
[TD="align: right"]100[/TD]
[/TR]
[TR]
[TD]ETC....[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[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