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

hiker95 - one more question I have some CallCodes that being with 00

When we get to <code>.Cells(2, 26).Resize(UBound(cc, 1)).Value = cc</code> the leading Zeros are dropped. I've tried but can't see what I need to do to keep the leading zeros.

Thx
Jon

 

[hiker95]

Re: Help

JonRowland,

hiker95 - one more question I have some CallCodes that being with 00

When we get to .Cells(2, 26).Resize(UBound(cc, 1)).Value = cc the leading Zeros are dropped. I've tried but can't see what I need to do to keep the leading zeros.

Can we have a screenshot, like your original reply, that contains some of the CallCodes that begin with 00?

 

[JonRowland]

Re: Help

hiker95

Can't give screenshot at the moment but example of codes would be;

001234
03456
00987653

HTH

 

[hiker95]

Re: Help

JonRowland,

Here is an updated macro for you to consider:

Sample raw data, and, results:

Excel 2007
	A	B	C	D	E	F	G
1	Time Period	CallCode		Call Code	00:00 - 05:59	06:00 - 11:59	15:00 - 20:59
2	00:00 - 05:59	Y24		Y24	1	0	0
3	00:00 - 05:59	001234		001234	1	0	0
4	06:00 - 11:59	X01		X01	0	1	1
5	06:00 - 11:59	03456		03456	0	2	0
6	06:00 - 11:59	03456		D09	0	0	1
7	15:00 - 20:59	D09		00987653	0	0	1
8	15:00 - 20:59	X01
9	15:00 - 20:59	00987653
10
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

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)
    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

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgTimePeriodCallCodeV2 macro.

 

[JonRowland]

Re: Help

Apologies hiker95...I forgot to response.

That work and is fantastic and I've been able to slip it into my main routine and get the result I want.

Many thanks for your help.

 

[hiker95]

Re: Help

JonRowland,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.

 

[JonRowland]

Re: Help

Sorry to bump this after so long. Hopefully Hiker95 can help. But I am trying to work out how to get this code to differentiate between lower and upper case and to treat them as separate entities.

For example I have y24 and Y24. So this ends up putting my count figures in the first y24 and nothing in Y24.

Anyone any clues?

Jon

JonRowland,

Here is an updated macro for you to consider:

Sample raw data, and, results:

Excel 2007
	A	B	C	D	E	F	G
1	Time Period	CallCode		Call Code	00:00 - 05:59	06:00 - 11:59	15:00 - 20:59
2	00:00 - 05:59	Y24		Y24	1	0	0
3	00:00 - 05:59	001234		001234	1	0	0
4	06:00 - 11:59	X01		X01	0	1	1
5	06:00 - 11:59	03456		03456	0	2	0
6	06:00 - 11:59	03456		D09	0	0	1
7	15:00 - 20:59	D09		00987653	0	0	1
8	15:00 - 20:59	X01
9	15:00 - 20:59	00987653
10
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

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)
    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

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgTimePeriodCallCodeV2 macro.

 

[hiker95]

Re: Help

Re: Help
Sorry to bump this after so long. Hopefully Hiker95 can help. But I am trying to work out how to get this code to differentiate between lower and upper case and to treat them as separate entities.

For example I have y24 and Y24. So this ends up putting my count figures in the first y24 and nothing in Y24.

Anyone any clues?

Jon

JonRowland,

Can you supply a screenshot that contains lower, and, upper Y, examples?

If you are not able to provide screenshots, then:

You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com

 

[JonRowland]

Re: Help

Hi,

Hopefully, this simple example will explain what the end result I am looking for. There will be duplicates and some of the values will be pure text, some numbers and some alpha numeric.

Jon

Book1
	A	B	C	D	E	F	G	H
1		A	B	C	D	E	F	G
2	1	Time Period	CallCode		Call Code	00:00 - 05:59	06:00 - 11:59	15:00 - 20:59
3	2	00:00 - 05:59	Y24		Y24	1	0	0
4	3	00:00 - 05:59	1234		1234	1	0	0
5	4	06:00 - 11:59	X01		X01	1	1	1
6	5	06:00 - 11:59	3456		3456	0	2	0
7	6	06:00 - 11:59	3456		D09	0	0	1
8	7	15:00 - 20:59	D09		987653	0	0	1
9	8	15:00 - 20:59	X01		x01	0	1	0
10	9	15:00 - 20:59	987653
11	10	06:00 - 11:59	x01
12	11	00:00 - 05:59	X01
Sheet1

 

[hiker95]

Re: Help

JonRowland,

I have not been able to duplicate your results in your reply #19.

Maybe MickG, a Guru with the Scripting.Dictionary, will see your request.