Converting horizontal list to vertical - VBA

[mhaidar81]

Hello all,

I am looking for a macro that would convert a horizontal list to a vertical one. All I can come up with is a macro to copy the row and paste it X number of times, but my list contains thousands of rows and doesn't seem very practical. Assuming ID column is column A:

A ---​ ID	B ---​ Project	C ---​ Rate	D --- Project A Count	E --- Project B Count	F --- Project C Count	G --- ​ Total	H ---​ Rate	I --- Project D Count	J --- Project E Count	K --- Project D Count	L --- ​ Total
1001	12001.01	$50	3	0	5	400	60	6	1	0	420

<tbody>
</tbody>

ID	Project	Project Name	Rate	Count	Total
1001	Project A	12001.01	$50	3	150
1001	Project B	12001.01	$50	0	0
1001	Project C	12001.01	$50	5	250
1001	Project D	FR0006	$60	6	360
1001	Project E	FR0003	$60	1	60
1001	Project F	FR0005	$60	0	0

<tbody>
</tbody>

After the list is converted:

• Project A, Project B, and Project C should always populate “Project Name” with the value from Column B
• Project D should populate “Project Name” with the value “FR0006”
• Project E should populate “Project Name” with the value “FR0003”
• Project F should populate “Project Name” with the value “FR0005”

I would appreciate any help with this

 

[mse330]

Will your data expands into more columns to have, for example Project G, Project H, Project I or it is fixed at Project F ? Also, project names for D, E, & F are always FR0006, FR0003 & FR0005 or is it reading from other cells ?

 

[mhaidar81]

I don't suspect that the data will go beyond F, and projects D, E, and F will be constant and not read from other cells.

 

[mhaidar81]

Any luck mse330? I appreciate any help you can provide.

 

[MickG]

Try this for results on sheet 2.

[COLOR="Navy"]Sub[/COLOR] MG23Jun38
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, col [COLOR="Navy"]As[/COLOR] Variant, num [COLOR="Navy"]As[/COLOR] Double, rate [COLOR="Navy"]As[/COLOR] Double, Tot [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] Aph [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
ReDim Ray(1 To Rng.Count * 7, 1 To 6)
c = 1
Ray(c, 1) = "ID": Ray(c, 2) = "Project": Ray(c, 3) = "Project Name": Ray(c, 4) = "Rate": Ray(c, 5) = "Count": Ray(c, 6) = "TotTotal"
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
  [COLOR="Navy"]For[/COLOR] Ac = 1 To 6
   [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Ac
        [COLOR="Navy"]Case[/COLOR] 1: Aph = 65: col = Dn.Offset(, 1).Value: rate _
            = Dn.Offset(, 2).Value: num = Dn.Offset(, 3).Value: Tot = num * rate
        [COLOR="Navy"]Case[/COLOR] 2: Aph = 66: col = Dn.Offset(, 1).Value: rate _
            = Dn.Offset(, 2).Value: num = Dn.Offset(, 4).Value: Tot = num * rate
        [COLOR="Navy"]Case[/COLOR] 3: Aph = 67: col = Dn.Offset(, 1).Value: rate _
            = Dn.Offset(, 2).Value: num = Dn.Offset(, 5).Value: Tot = num * rate
        [COLOR="Navy"]Case[/COLOR] 4: Aph = 68: col = "FR0006": rate = Dn.Offset(, 7).Value: _
            num = Dn.Offset(, 8).Value: Tot = num * rate
        [COLOR="Navy"]Case[/COLOR] 5: Aph = 69: col = "FR0003": rate = Dn.Offset(, 7).Value: _
            num = Dn.Offset(, 9).Value: Tot = num * rate
        [COLOR="Navy"]Case[/COLOR] 6: Aph = 70: col = "FR0005": rate = Dn.Offset(, 7).Value: _
            num = Dn.Offset(, 10).Value: Tot = num * rate
   [COLOR="Navy"]End[/COLOR] Select
    c = c + 1
    Ray(c, 1) = Dn.Value: Ray(c, 2) = "Project " & Chr(Aph): Ray(c, 3) = col
    Ray(c, 4) = rate: Ray(c, 5) = num: Ray(c, 6) = Tot
 [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 6)
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[mhaidar81]

That was amazing! Thank you so much, Mick. It works beautiful.

 

[mse330]

Any luck mse330? I appreciate any help you can provide.

Apologies couldn't finish off the code last night … I see that MickG has already done the required

This is my code anyway

Sub table()
Dim Arr1() As Variant, Arr2() As Variant, Rg As Range, lRow As Long, Itm As Variant, ws As Worksheet
Dim Proj_Code As String, Proj_Name As String, Rate As Double, Cnt As Double
Set Rg = ActiveSheet.Range("A1").CurrentRegion
Arr1 = Rg
ReDim Arr2(1 To Rg.Rows.Count * 6, 1 To 6)
For x = 2 To Rg.Rows.Count
    For y = 1 To 6
        Select Case y
            Case 1: Proj_Code = "Project A": Proj_Name = Arr1(x, 2): Rate = Arr1(x, 3): Cnt = Arr1(x, 4)
            Case 2: Proj_Code = "Project B": Proj_Name = Arr1(x, 2): Rate = Arr1(x, 3): Cnt = Arr1(x, 5)
            Case 3: Proj_Code = "Project C": Proj_Name = Arr1(x, 2): Rate = Arr1(x, 3): Cnt = Arr1(x, 6)
            Case 4: Proj_Code = "Project D": Proj_Name = "FR0006": Rate = Arr1(x, 8): Cnt = Arr1(x, 9)
            Case 5: Proj_Code = "Project E": Proj_Name = "FR0003": Rate = Arr1(x, 8): Cnt = Arr1(x, 10)
            Case 6: Proj_Code = "Project F": Proj_Name = "FR0005": Rate = Arr1(x, 8): Cnt = Arr1(x, 11)
        End Select
        lRow = lRow + 1
        Arr2(lRow, 1) = Arr1(x, 1)
        Arr2(lRow, 2) = Proj_Code
        Arr2(lRow, 3) = Proj_Name
        Arr2(lRow, 4) = Rate
        Arr2(lRow, 5) = Cnt
        Arr2(lRow, 6) = Rate * Cnt
     Next y
Next x
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
With ws
    .Range("A1").Resize(UBound(Arr2), 6).Value = Arr2
    .Rows(1).Insert
    .Range("A1:F1") = Array("ID", "Project", "Project Name", "Rate", "Count", "Total")
    .Columns.AutoFit
End With
End Sub

 

[mhaidar81]

No worries, thank you kindly!

 

[MickG]

You're welcome

 

[mse330]

You are welcome