VBA macro to Arrange data in different form

[StupidCoffee]

I am trying to organize my raw data into a different form chart to help me build a special trend.
I have one sheet with name, date, and shortened names for each component.
As a result of this macro I need a table that shows name, description (which will be repeated), date, and value of the component

Here is a sample

Raw:

Name	Date	.H	.O	.N
A	3/12/2013	1	2	3
A	5/10/2013	4	5	6
A	6/2/2013	7	8	9
B	1/22/2013	10	11	12
B	3/15/2013	13	14	15
B	5/20/2013	16	17	18

<colgroup><col><col><col><col span="2"></colgroup><tbody>
</tbody>

Result:

Name	Description	Date	Value
A.H	Hydrogen	3/12/2013	1
A.O	Oxygen	3/12/2013	2
A.N	Nitrogen	3/12/2013	3
A.H	Hydrogen	5/10/2013	4
A.O	Oxygen	5/10/2013	5
A.N	Nitrogen	5/10/2013	6
A.H	Hydrogen	6/2/2013	7
A.O	Oxygen	6/2/2013	8
A.N	Nitrogen	6/2/2013	9
B.H	Hydrogen	1/22/2013	10
B.O	Oxygen	1/22/2013	11
B.N	Nitrogen	1/22/2013	12
B.H	Hydrogen	3/15/2013	13
B.O	Oxygen	3/15/2013	14
B.N	Nitrogen	3/15/2013	15
B.H	Hydrogen	5/20/2013	16
B.O	Oxygen	5/20/2013	17
B.N	Nitrogen	5/20/2013	18

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

I tried using INDEX function, but I need a macro code for this.

Please help..

 

[StupidCoffee]

Actually, the description column is not needed

 

[JoeMo]

Actually, the description column is not needed

This assumes your data start in A2 and produces a rearranged version (including description) beginning in H2 of the same sheet:

Sub RearrangeMyMolecules()
Dim lR As Long, R As Range, vA As Variant, Hdrs As Variant, nR As Long, O(1 To _
    4) As Variant, S As Variant, SF As Variant
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A2", "E" & lR)
vA = R.Value
Hdrs = Array("Name", "Description", "Date", "Value")
S = Array(".H", ".O", ".N")
SF = Array("Hydrogen", "Oxygen", "Nitrogen")
Range("H1:K1").Value = Hdrs
Application.ScreenUpdating = False
For i = LBound(vA, 1) To UBound(vA, 1)
    For j = 0 To 2
        nR = Range("H" & Rows.Count).End(xlUp).Row + 1
        O(1) = vA(i, 1) & S(j)
        O(2) = SF(j)
        O(3) = vA(i, 2)
        O(4) = vA(i, j + 3)
        Range("H" & nR).Resize(1, 4).Value = O
        Erase O
    Next j
Next i
Columns("H:K").AutoFit
End Sub

 

[StupidCoffee]

Thank you so much!

If I want to produce the result on a new sheet, would I just change the Range("H1:K1") to a desired sheet and range?

 

[JoeMo]

Thank you so much!

If I want to produce the result on a new sheet, would I just change the Range("H1:K1") to a desired sheet and range?

This will create a new sheet named "RearrangedData" and put the results on it starting in A1 if you run the code from your raw data sheet. Each time you run the code it will replace the contents of the RearrangedData sheet.

Sub RearrangeMyMolecules()
'Run this code from the sheet the raw data are on
Dim lR As Long, R As Range, vA As Variant, Hdrs As Variant, nR As Long, O(1 To _
    4) As Variant, S As Variant, SF As Variant, sSht As Worksheet
    
Set sSht = ActiveSheet
lR = sSht.Range("A" & Rows.Count).End(xlUp).Row
Set R = sSht.Range("A2", "E" & lR)
vA = R.Value
Hdrs = Array("Name", "Description", "Date", "Value")
S = Array(".H", ".O", ".N")
SF = Array("Hydrogen", "Oxygen", "Nitrogen")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("RearrangedData").Delete
On Error GoTo 0
Sheets.Add after:=sSht
ActiveSheet.Name = "RearrangedData"
With Sheets("RearrangedData")
    .Range("A1:D1").Value = Hdrs
    For i = LBound(vA, 1) To UBound(vA, 1)
        For j = 0 To 2
            nR = .Range("A" & Rows.Count).End(xlUp).Row + 1
            O(1) = vA(i, 1) & S(j)
            O(2) = SF(j)
            O(3) = vA(i, 2)
            O(4) = vA(i, j + 3)
            .Range("A" & nR).Resize(1, 4).Value = O
            Erase O
        Next j
    Next i
    .Columns("A:D").AutoFit
End With
sSht.Select
End Sub

 

[StupidCoffee]

Thank you so much!

This is very helpful !!

 

[JoeMo]

Thank you so much!

This is very helpful !!

You are welcome. Thanks for the reply.