Summarize Data to New Sheet

[James Niven]

Hi All,

I am looking for a VBA solution here to my raw data tab.
Please refer to my attached spreadsheet for details.

Basically, the "RawData" tab is how I receive the information. On the "Final Output" tab is how I want the data summarized by each driver for that one day.

Can some please help out with some vba code I can run daily to collate this information as I have to enter this summarized data into another spreadsheet for each driver, the number of rows can be several hundred each day.Summarizedemo3.xlsx

Thanks in advance!!

[Bob Phillips]

This is easily done in Power Query. Form your data as a table, and use this script

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Removed Columns" = Table.RemoveColumns(Source,{"DLDATE", "DLROUT", "DLVEHL", "DLCARV", "DLCDPT", "DLWO#", "Container", "Action", "CSADR3", "ADDRESS", "DISPOSAL", "CSUSER", "Pk or Del?"}),
    #"Grouped Rows" = Table.Group(#"Removed Columns", {"DNAME", "Zone"}, {{"Count", each Table.RowCount(_), type number}}),
    #"Sorted Rows" = Table.Sort(#"Grouped Rows",{{"DNAME", Order.Ascending}, {"Zone", Order.Ascending}}),
    #"Pivoted Column" = Table.Pivot(#"Sorted Rows", List.Distinct(#"Sorted Rows"[Zone]), "Zone", "Count", List.Sum)
in
    #"Pivoted Column""

[James Niven]

xld,

Thanks for your reply and the use of Power Query for a solution to my excel spreadsheet.
I have not used Power Query at all, so I do not know where to begin using this.
I would prefer a VBA solution though to my problem.

[rlv]

Btw, you have needed columns

"EY1"
"RELO1"
"Yd Box"

On the output sheet, but none of those strings appear in your raw data.

[James Niven]

rtv,

Thanks for the reply, yes there are about 43 possible Zones, but not all of them are used everyday, so, I just want to summarize what is used at one time.

[Bob Phillips]

I would prefer a VBA solution though to my problem.

You should learn PQ, it is very flexible, very powerful. MS are constantly improving and enhancing it, something that will never again happen for VBA.

The solution I gave handles as many zones as you have, no changes required as that data flexes.

[Bob Phillips]

I would prefer a VBA solution though to my problem.

You should learn PQ, it is very flexible, very powerful. MS are cionstantly improving and enhancing it, something that will never again happen for VBA.

The solution I gave handles as manyzones as you have, no changes required as that data flexes.

[James Niven]

Thanks xld!
Yes, I know I should take the time to learn PQ. Can you point me in the direction of a good tutorial?
But, in the mean time I am still looking for a VBA solution for this spreadsheet?

Thanks

[Bob Phillips]

I hate to do it, the VBA is more complex, less robust, and generally worse, but here goes

Public Sub SummarizeData()
Dim ws As Worksheet
Dim firstrow As Long
Dim lastrow As Long
Dim lastcol As Long
Dim numrows As Long
    
    Set ws = Worksheets.Add
    
    With Worksheets("RawData")
    
        firstrow = .Range("A1").End(xlDown).Row
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        numrows = lastrow - firstrow + 1
        
        'get unique list of drivers
        .Cells(firstrow, "C").Resize(numrows).Copy ws.Range("A1")
        ws.Range(ws.Range("A1"), ws.Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
        ws.Columns("A:A").EntireColumn.AutoFit
        
        'get unique list of Zone
        .Cells(firstrow, "N").Resize(numrows).Copy ws.Range("B1")
        ws.Range(ws.Range("B1"), ws.Cells(ws.Rows.Count, "B").End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
        
        'get unique list of Pk or Del?
        .Cells(firstrow, "O").Resize(numrows).Copy ws.Range("C1")
        ws.Range(ws.Range("C1"), ws.Cells(ws.Rows.Count, "C").End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
    End With
    
    With ws
    
        'merge Zone and Pk or Del? lists and setup as headings
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        numrows = .Cells(.Rows.Count, "C").End(xlUp).Row - 1
        .Range(.Range("C2"), .Cells(.Rows.Count, "C").End(xlUp)).Cut Destination:=.Cells(lastrow, "B").Resize(numrows)
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        .Range("B2").Resize(lastrow - 1).Copy
        .Range("B1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        .Range("B2").Resize(lastrow - 1).ClearContents
        
        'setup formula to count instances
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        .Range("B2").Resize(lastrow - 1, lastcol - 1).FormulaR1C1 = "=COUNTIFS(RawData!C3,RC1,RawData!C14,R1C)+COUNTIFS(RawData!C3,RC1,RawData!C15,R1C)"
    End With
End Sub

[James Niven]

xld,

I have had a chance today to review the vba solution you have for me, firstly, thanks for going the extra mile, this is fantastic and your code works as requested.
Can you update the code to not show the zeros if that driver does not have an A zone for instant, I just would like to see the count of zones only?

Also, for my education, below, on where it says "Copy ws.Range("B1")", on my sheet is a vlookup formula, how can I change this code to paste special values? I know the demo did not have this, it is straight values.

       'get unique list of Zone
        .Cells(firstrow, "N").Resize(numrows).Copy ws.Range("B1") 
        ws.Range(ws.Range("B1"), ws.Cells(ws.Rows.Count, "B").End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo

Thanks again for your patience!!

[mdmackillop]

A small change after the Formula line.

     'setup formula to count instances
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        With .Range("B2").Resize(lastrow - 1, lastcol - 1)
            .FormulaR1C1 = "=COUNTIFS(RawData!C3,RC1,RawData!C14,R1C)+COUNTIFS(RawData!C3,RC1,RawData!C15,R1C)"
            .Value = .Value
            .NumberFormat = "0;-0;"
        End With

[Bob Phillips]

Nothing wrong with Malcolm's addition, but I noticed a few other things I didn't like in the final layout; there was a blank column; fonts varied; and the columns were not ordered. This version addresses all of those

Public Sub SummarizeData()
Dim ws As Worksheet
Dim firstrow As Long
Dim lastrow As Long
Dim lastcol As Long
Dim numrows As Long
Dim i As Long
    
    Application.ScreenUpdating = False
    
    Set ws = Worksheets.Add
    
    With Worksheets("RawData")
    
        firstrow = .Range("A1").End(xlDown).Row
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        numrows = lastrow - firstrow + 1
        
        'get unique list of drivers
        .Cells(firstrow, "C").Resize(numrows).Copy ws.Range("A1")
        ws.Range(ws.Range("A1"), ws.Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
        
        'get unique list of Zone
        .Cells(firstrow, "N").Resize(numrows).Copy ws.Range("B1")
        ws.Range(ws.Range("B1"), ws.Cells(ws.Rows.Count, "B").End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
        
        'get unique list of Pk or Del?
        .Cells(firstrow, "O").Resize(numrows).Copy ws.Range("C1")
        ws.Range(ws.Range("C1"), ws.Cells(ws.Rows.Count, "C").End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
    End With
    
    With ws
    
        'merge Zone and Pk or Del? lists and setup as headings
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        numrows = .Cells(.Rows.Count, "C").End(xlUp).Row - 1
        .Range(.Range("C2"), .Cells(.Rows.Count, "C").End(xlUp)).Cut Destination:=.Cells(lastrow, "B").Resize(numrows)
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        .Range("B2").Resize(lastrow - 1).Copy
        .Range("B1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        .Range("B2").Resize(lastrow - 1).ClearContents
        
        'setup formula to count instances
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        With .Range("A1").Resize(lastrow, lastcol)
        
            With .Font
            
                .Name = "Calibri"
                .Size = 11
            End With
        End With
        
        With .Range("B2").Resize(lastrow - 1, lastcol - 1)
        
            .FormulaR1C1 = "=COUNTIFS(RawData!C3,RC1,RawData!C14,R1C)+COUNTIFS(RawData!C3,RC1,RawData!C15,R1C)"
            .Value = .Value
            .NumberFormat = "General;;"
        End With
        .Columns("A:A").EntireColumn.AutoFit
        
        'sort columns and remove blanks
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("B1").Resize(, lastcol - 1), _
                             SortOn:=xlSortOnValues, _
                             Order:=xlAscending, _
                             DataOption:=xlSortNormal
        With .Sort
        
            .SetRange ws.Range("B1").Resize(lastrow - 1, lastcol - 1)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlLeftToRight
            .SortMethod = xlPinYin
            .Apply
        End With
        
        For i = lastcol To 2 Step -1
        
            If .Cells(1, i).Value = "" Then
            
                .Columns(i).Delete
            Else
        
                Exit For
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub

[James Niven]

mdmackillop,

Thanks for your variation to xld's code, this works like a charm, very much appreciated.

[James Niven]

xld,

Also, thanks for the additional enhancements to the code, I did see these items you mentioned above and thanks for addressing them.

So, I have been testing the modified code on the my real data and seems to be giving the correct results mostly, it is missing some zones.
I copied and paste special values columns N and O and ran the code and the missing zones are displayed.
I think the issue I am seeing is some of the zones are not being displayed on the new sheet due to the vlookup formula I have which I use to drop in the correct zone under column N based on the grid reference under column M.
I use this spreadsheet every day so, I need to leave in the vlookup formula.

How can I paste special values where it says "Get Unique list of zones"? I know the demo did not have a formula, it had straight values.

Also, when I run the code there is "Type Mismatch" at this line near the bottom of the code. If I comment these lines out the code runs fine.

            If .Cells(1, i).Value = "" Then

Thanks again for your assistance!

[Bob Phillips]

Post an example that shows this discrepancy.

[James Niven]

xld,

Thanks, here is the real data spreadsheet, I have desensitized the data as much as possible, but it still works.

I have also noted one other issue between my last post and now. If you look at driver BROD1 and ACAN1, they both had E2 zones, they do not display on the new sheet, I think when you copy the data from column C, it pastes on top of E2 before the zones are transposed to columns.

Thanks

[James Niven]

Bump

[rlv]

My attempt

[James Niven]

Hi rlv,

Thanks for your contribution to my task, this works very well and I see your approach.
I am learning VBA slowly and I have learnt a lot from xld and how he tackled my task.

One thing I did notice was on the "Results" sheet, the drivers are in alphabetically order, can we set this to the order they appear on the pivot sheet. The reason for this, I transfer the results data to another spreadsheet and that spreadsheet is in the order as the pivot data.

Thanks and I appreciate your offer to assist me.

[rlv]

If you stick with VBA, one thing that will become clear is that there is almost always more than one way to accomplish a given task, and you can learn a lot from comparing different approaches. I've been using VBA for a good while now and I'm at the point where I can more or less code anything I want to do without outside input. But that leads to always solving certain problems in certain ways, so for me, the value of a site like this is to see how other people code things which gets me out of my comfort zone and tying new things.

Per the driver order, you can comment out the first sort statement and the order should then match the pivot sheet.