Code to produce pivot like summary

[JonRowland]

Hi Forum experts. I am hoping someone can help with some VBA code for me to do the following, as all my attempts have failed

For the purpose of this post I have simplified my example data but will likely have around 6-7 time periods and x amount of CallCodes.

What I start with is a list of Time Periods and CallCode that occurred within the period, as below

[table="width: 500, class: grid, align: center"]
[tr]
[td]Time Period[/td]
[td]CallCode[/td]
[/tr]
[tr]
[td]00:00 - 05:59[/td]
[td]Y24[/td]
[/tr]
[tr]
[td]06:00 - 11:59[/td]
[td]X01[/td]
[/tr]
[tr]
[td]15:00 - 20:59[/td]
[td]D09[/td]
[/tr]
[tr]
[td]15:00 - 20:59[/td]
[td]X01[/td]
[/tr]
[/table]

What I am trying to do is produce a result like this

[table="width: 500, class: grid, align: center"]
[tr]
[td]CallCode[/td]
[td]00:00 - 05:59
[/td]
[td]06:00 - 11:59[/td]
[td]15:00 - 20:59[/td]
[/tr]
[tr]
[td]Y24[/td]
[td]1[/td]
[td]0[/td]
[td]0[/td]
[/tr]
[tr]
[td]X01[/td]
[td]0[/td]
[td]1[/td]
[td]1[/td]
[/tr]
[tr]
[td]D09[/td]
[td]0[/td]
[td]0[/td]
[td]1[/td]
[/tr]
[/table]

Before anyone asks why not use a Pivot Table this is part of a bigger routine and what to include this automated part.

 

[JonRowland]

Re: Help

Thanks for trying hiker95.

Maybe if I tag MickG he will look/

 

[hiker95]

Re: Help

Thanks for trying hiker95.

JonRowland,

You are welcome.

Maybe if I tag MickG he will look/

I did try to send MickG a Private Message, but, his mailbox was full.

 

[hiker95]

Re: Help

JonRowland,

MickG has cleaned out his mailbox.

You can now send MickG a Private Message.

 

[JonRowland]

Re: Help

Well. I decided one last look with a fresh head before a PM MickG & then I worked out what I need. Simple really, just not thought of it. Basically need to include in the FIND to Match Case (See Red in code below). It's working so far on my data.

Sub ReorgTimePeriodCallCodeV2()
' hiker95, 03/06/2015, ME840231
Dim c As Range, rng As Range, tp, cc
Dim r As Range, d As Range
With ActiveSheet
.Cells(1, 4) = "Call Code"
Set rng = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
With CreateObject("Scripting.Dictionary")
For Each c In rng
If c <> "" Then
If Not .Exists(c.Value) Then
.Add c.Value, c.Value
End If
End If
Next
cc = Application.Transpose(Array(.Keys))
End With
With .Cells(2, 4).Resize(UBound(cc, 1))
.NumberFormat = "@"
.Value = cc
End With
Set rng = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
With CreateObject("Scripting.Dictionary")
For Each c In rng
If c <> "" Then
If Not .Exists(c.Value) Then
.Add c.Value, c.Value
End If
End If
Next
tp = Application.Transpose(Array(.Keys))
End With
.Cells(1, 5).Resize(, UBound(tp, 1)) = Application.Transpose(tp)
.Columns(4).Resize(, UBound(tp) + 1).AutoFit
.Range("E2").Resize(UBound(cc), UBound(tp)) = 0
For Each c In .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
Set d = .Columns(4).Find(c.Value, LookAt:=xlWhole,MatchCase:=True)
Set r = .Rows(1).Find(c.Offset(, -1).Value, LookAt:=xlWhole)
If (Not d Is Nothing) * (Not r Is Nothing) Then
.Cells(d.Row, r.Column) = .Cells(d.Row, r.Column) + 1
End If
Next c
End With
End Sub

 

[hiker95]

Re: Help

Re: Help
Well. I decided one last look with a fresh head before a PM MickG & then I worked out what I need. Simple really, just not thought of it. Basically need to include in the FIND to Match Case (See Red in code below). It's working so far on my data.

JonRowland,

Thanks for the update, and, nicely done.

And, come back anytime.