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.

 

[lexusap]

Re: Help

Hi,

I would use column helper before going into VBA.

your column helper would be

[TABLE="width: 714"]
<tbody>[TR]
[TD]Time Period[/TD]
[TD]CallCode[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]00:00 - 05:59[/TD]
[TD]Y24[/TD]
[TD]00:00 - 05:59Y24[/TD]
[TD]=A2&B2[/TD]
[/TR]
[TR]
[TD]06:00 - 11:59[/TD]
[TD]X01[/TD]
[TD]06:00 - 11:59X01[/TD]
[TD]=A3&B3[/TD]
[/TR]
[TR]
[TD]15:00 - 20:59[/TD]
[TD]D09[/TD]
[TD]15:00 - 20:59D09[/TD]
[TD]=A4&B4[/TD]
[/TR]
[TR]
[TD]15:00 - 20:59[/TD]
[TD]X01[/TD]
[TD]15:00 - 20:59X01[/TD]
[TD]=A5&B5[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]What I am trying to do is produce a result like this[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[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="align: right"]1[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]0[/TD]
[/TR]
[TR]
[TD]X01[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]D09[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[/TR]
</tbody>[/TABLE]

for the first code (Y24 & 00:00 - 05:59) type in "=IF(ISERROR(VLOOKUP(B$9&$A10,$C$2:$C$5,1,FALSE)),0,1)" and then copy paste the remaining.

Cheers
Lex

 

[hiker95]

Re: Help

JonRowland,

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?

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

3. Can we have a list of all the time periods?

 

[JoeMo]

Re: Help

This assumes your data are in cols A & B (see below) and reconfigures them as shown below. The columns housing the reconfigured data must be empty prior to running the macro.

Excel Workbook
	A	B	C	D	E	F	G
1	Time Period	CallCode		CallCode	00:00 - 05:59	06:00 - 11:59	15:00 - 20:59
2	00:00 - 05:59	Y24		Y24	1	0	0
3	06:00 - 11:59	X01		X01	0	1	1
4	15:00 - 20:59	D09		D09	0	0	1
5	15:00 - 20:59	X01
Sheet1 (2)

Sub RearrangeCallData()
Dim R1 As Range, V1 As Variant, i As Long, R2 As Range, V2 As Variant, j As Long, k As Long
Set R1 = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
V1 = R1.Value
Application.ScreenUpdating = False
R1.Columns(1).AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("D1"), unique:=True
With Range("D1", Range("D1").End(xlDown))
    .Offset(1, 0).Copy
    Range("E1").PasteSpecial xlPasteValues, Transpose:=True
    .ClearContents
    R1.Columns(2).AdvancedFilter Action:=xlFilterCopy, copytorange:=.Cells(1, 1), unique:=True
End With
Set R2 = Range("D1", Range("D1").End(xlToRight))
V2 = R2.Value
For k = 2 To Range("D1", Range("D1").End(xlDown)).Rows.Count
    For i = LBound(V1, 1) + 1 To UBound(V1, 1)
        For j = LBound(V2, 2) + 1 To UBound(V2, 2)
            If V1(i, 1) = V2(1, j) And V1(i, 2) = Cells(k, "D") Then Cells(k, j + 3).Value = Cells(i, j + 3).Value + 1
        Next j
    Next i
Next k
On Error Resume Next
Range("D1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Value = 0
On Error GoTo 0
R2.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

 

[azumi]

Re: Help

Solitions with formulas, please follow this links, im make example based your data

https://www.dropbox.com/s/rd6njk2fgznx14b/Example.xlsx?dl=0

cheers

 

[hiker95]

Re: Help

JonRowland,

Here is another macro solution for you to consider.

Sample raw data, and, results in the active worksheet:

Excel 2007
	A	B	C	D	E	F	G	H
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	06:00 - 11:59	X01		X01	0	1	1
4	15:00 - 20:59	D09		D09	0	0	1
5	15:00 - 20:59	X01
6
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).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgTimePeriodCallCode()
' hiker95, 03/04/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
  .Cells(2, 4).Resize(UBound(cc, 1)).Value = cc
  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 ReorgTimePeriodCallCode macro.

 

[JonRowland]

Re: Help

Hi Guys,

Now daytime in the UK. Thanks for all your examples. With the code provided I should be able to tweak to get exactly what I am after.

lexusap / azumi - I need VBA and will fit in a bigger routine I have.
hiker95 - I won't anser your questions (XL07, PC & WIN8.1 & time period will be changing but will be presented with the data.) Opps I did answer . Your code almost worked expect I wanted a a count rather than 1 to indictae it the code appears within that time period.
and finally JoeMo - spot on and what I was after.

Thanks guys once again. This is the one site you def get more than you pay for.

 

[hiker95]

Re: Help

JonRowland,

Your code almost worked expect I wanted a a count rather than 1 to indictae it the code appears within that time period.

Your posted raw data did not have any duplicates. If it had, then the following lines of code, for each duplicate, would add 1 to the results:

    If (Not d Is Nothing) * (Not r Is Nothing) Then
      .Cells(d.Row, r.Column) = .Cells(d.Row, r.Column) + 1
    End If

 

[JonRowland]

Re: Help

Ap0ologies I got you Hiker95 mixed with JoeMo. Your code worked at I was hoping. Once again sorry.

 

[hiker95]

Re: Help

JonRowland,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.