Rows to Columns

[amyincalgary]

Hi,

I searched the boards and found thread 22810 (can't post the link for some reason) but I don't have enough expertise to tailor it to my needs. I'm hoping someone can help me!

I have a table that spans from columns A-O but I only need columns A - I (I don't want to delete J - O). In column G is hours of the day and in column H & I are corresponding Volumes and Prices. I would like to pivot the hours so each hour is in one column, for both Volumes and Prices. I can't use a pivot table to do this (won't go into detail why).

What is it now:

ColA ... ColF ColG ColH ColI ........
(Name) (Cat) (Hr) (Vol) ($)
ABC 123 H1 25 35.75
ABC 123 H2 30 26.85
. . . . .
. . . . .
ABC 123 H24 15 16.95
DEF 456 H1 65 87.75
DEF 456 H2 90 96.15
. . . . .
. . . . .
DEF 456 H24 40 56.45


What I want it to be:

ColA ... ColF ColG ColH ColI ColJ ... ColBA ColBB
(Nam) ... (Cat) (H1Vol) (H1$) (H2Vol) (H2$) ... (H24Vol) (H24$)
ABC 123 25 35.75 30 26.85 15 16.95
DEF 456 65 87.75 90 96.15 40 56.45

Any ideas?



Thank you in advance!!!

[mdmackillop]

Welcome to VBAX
Can you post a sample? Use Manage Attachments in the Go Advanced reply section

[Krishna Kumar]

OK.

Try this one.

[vba]Sub Rows2Cols()
Dim a, k(), i As Long, n As Long, j As Long, w(), ws As Worksheet
a = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 9).Value
ReDim w(1 To UBound(a, 1), 1 To Columns.Count)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
n = n + 1
w(n, 1) = a(i, 1): w(n, 2) = a(i, 6)
w(n, 3) = a(i, 8): w(n, 4) = a(i, 9)
.Add a(i, 1), Array(n, 4)
Else
k = .Item(a(i, 1))
x = CInt(Replace(a(i, 7), "H", ""))
x = x * 2 + 1
w(k(0), x) = a(i, 8): x = x + 1
w(k(0), x) = a(i, 9)
.Item(a(i, 1)) = k
End If
Next
End With
On Error Resume Next
Set ws = Sheets("Summary")
On Error GoTo 0
If ws Is Nothing Then
Worksheets.Add().Name = "Summary"
Set ws = Sheets("Summary")
End If
With ws.Range("a1")
.CurrentRegion.ClearContents
.Value = "Name"
.Offset(, 1).Value = "Cat"
For i = 2 To 48 Step 2
j = j + 1
.Offset(, i).Value = "H" & j & "Vol"
.Offset(, i + 1).Value = "H" & j & "$"
Next
.Offset(1).Resize(n, 50).Value = w
End With
Set ws = Nothing: Set dic = Nothing
End Sub[/vba]

HTH

[amyincalgary]

Thanks mdmackillop! This is a great site!

I've attached an example. The first section is the raw data and underneath I've shown the columns I want outputted. Hope this helps. THANK YOU!

Krishna Kumar:
Thanks for you suggestion. I ran the code but it stopped at

w(k(0), x) = a(i, 8): x = x + 1

with the message out of range.

[Krishna Kumar]

Hi,

Try

[vba]Sub Rows2Cols()
Dim a, k(), i As Long, n As Long, j As Long, w()
Dim ws As Worksheet, c As Long, s As String
a = Sheets("Sheet2").Range("a1").CurrentRegion.Resize(, 9).Value
ReDim w(1 To UBound(a, 1), 1 To 54)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
s = a(i, 1) & ";" & a(i, 2)
If Not .exists(s) Then
n = n + 1
For c = 1 To 6
w(n, c) = a(i, c)
Next
x = (a(i, 7) / 100) * 2 + 5
w(n, x) = a(i, 8)
w(n, x + 1) = a(i, 9)
.Add s, Array(n, 54)
Else
k = .Item(s)
x = (a(i, 7) / 100) * 2 + 5
w(k(0), x) = a(i, 8): x = x + 1
w(k(0), x) = a(i, 9)
.Item(s) = k
End If
Next
End With
On Error Resume Next
Set ws = Sheets("Summary")
On Error GoTo 0
If ws Is Nothing Then
Worksheets.Add().Name = "Summary"
Set ws = Sheets("Summary")
End If
With ws.Range("a1")
.CurrentRegion.ClearContents
.Value = a(1, 1)
For c = 1 To 5
.Offset(, c).Value = a(1, c + 1)
Next
For i = 6 To 53 Step 2
j = j + 1
.Offset(, i).Value = "HE" & j & "Vol"
.Offset(, i + 1).Value = "HE" & j & "Price"
Next
.Offset(1).Resize(n, 54).Value = w
End With
Set ws = Nothing: Set dic = Nothing
End Sub
[/vba]

HTH

[amyincalgary]

Hi Krishna,

Thanks for the quick response. I ran the code and it worked great with the data I provided (re-tooled to exclude confidental info) but when I ran the code on my data it didn't quite work. I took my original and changed some of the names , ran the code and created a pivot table to compare. I've attached my results.

Thanks!
Amy

[Krishna Kumar]

[vba]Sub Rows2Cols()
Dim a, k(), i As Long, n As Long, j As Long, w()
Dim ws As Worksheet, c As Long, s As String
a = Sheets("Sheet2").Range("a1").CurrentRegion.Resize(, 9).Value
ReDim w(1 To UBound(a, 1), 1 To 54)
With CreateObject("Scripting.Dictionary")
.comparemode = vbTextCompare
For i = 2 To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
For c = 1 To 6: s = s & ";" & a(i, c): Next
s = Mid$(s, 2)
If Not .exists(s) Then
n = n + 1
For c = 1 To 6
w(n, c) = a(i, c)
Next
x = (a(i, 7) / 100) * 2 + 5
w(n, x) = a(i, 8)
w(n, x + 1) = a(i, 9)
.Add s, Array(n, 54)
Else
k = .Item(s)
x = (a(i, 7) / 100) * 2 + 5
w(k(0), x) = w(k(0), x) + a(i, 8): x = x + 1
w(k(0), x) = w(k(0), x) + a(i, 9)
.Item(s) = k
End If
s = ""
End If
Next
End With
On Error Resume Next
Set ws = Sheets("Summary")
On Error GoTo 0
If ws Is Nothing Then
Worksheets.Add().Name = "Summary"
Set ws = Sheets("Summary")
End If
With ws.Range("a1")
.CurrentRegion.ClearContents
.Value = a(1, 1)
For c = 1 To 5
.Offset(, c).Value = a(1, c + 1)
Next
For i = 6 To 53 Step 2
j = j + 100
.Offset(, i).Value = "HE" & j & "Volume"
.Offset(, i + 1).Value = "HE" & j & "Price"
Next
.Offset(1).Resize(n, 54).Value = w
End With
Set ws = Nothing: Set dic = Nothing
End Sub[/vba]

HTH

[amyincalgary]

Works great! Thank you so much Krishna!!!

[Krishna Kumar]

Works great! Thank you so much Krishna!!!

You are welcome!!