Harry_1234

New Member
Joined
Aug 19, 2017
Messages
31
Time to decide what would be best for the future so that solution ...
- provides a single report of everything required
- and (if necessary) additional options for further flexibility

To avoid user confusion ... consider making numbers not in subtotals very obvious!
Items could be marked with an asterisk within current layout (but that is a bit messy) or consider alternative layouts

eg - separate column for excluded items
View attachment 15177

eg - different column for each site with excluded items listed in lower section
(could insert a total column for all sites in Column B)
View attachment 15176

Post a picture if you prefer a different layout

Q Is the same list of headers to be excluded EVERY time, or would you want flexibility to exclude headers of your choosing at time of running report?
Hello,

The second example of having different columns for each site with excluded items listed in lower section is an ideal solution that will perfectly work for me and end users. If i could also have the flexibility to exclude headers of my choice at the time of running report that will be really great. Thanks for all your help until now.
 

Some videos you may like

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,007
Office Version
365
Platform
Windows
Put code below in a NEW module and run Summarise2

Please confirm that the VALUES are correct
The code to exclude DID's will be posted later today or tomorrow
VBA Code:
Option Explicit

Private Summary As Worksheet, ws As Worksheet, Cel As Range, x As Long, y As Long
Private Func As WorksheetFunction
Private dID As New Collection, ValidNames As New Collection, Nm As String

Sub Summarise2()
    Application.ScreenUpdating = False
    Call Basics
    Call ValidSheets
    Call WriteColumnA
    Call WriteValues
End Sub
Private Sub Basics()
    Set Summary = Sheets("Summary")
    Set Func = WorksheetFunction
    Summary.Cells.Clear
End Sub
Private Sub ValidSheets()
    Set ValidNames = Nothing
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Summary", "Sheet1", "Check"         '(ignored)
            Case Else:  ValidNames.Add ws.Name
        End Select
    Next ws
End Sub
Private Sub WriteColumnA()
    Set dID = Nothing
        For x = 1 To ValidNames.Count
            On Error Resume Next
            For Each Cel In Sheets(ValidNames(x)).Range("1:1").SpecialCells(xlCellTypeConstants)
                dID.Add Cel.Text, Cel.Text
            Next Cel
            On Error GoTo 0
        Next x
    For x = 1 To dID.Count: Summary.Cells(x + 1, 1) = dID(x): Next
End Sub
Private Sub WriteValues()
    For x = 1 To ValidNames.Count
        Nm = ValidNames(x)
        Summary.Cells(1, x + 1) = Nm
        For y = 1 To dID.Count
            Summary.Cells(y + 1, x + 1) = GetCount(Nm, dID(y))
        Next y
    Next x
    Summary.Cells(1, 1).CurrentRegion.Offset(1).Sort Key1:=Summary.Cells(2, 1), Order1:=xlAscending
End Sub
Private Function GetCount(ByVal shName As String, ByVal idStr As String) As Variant
    Dim c As Long
    On Error Resume Next
    With Sheets(shName)
        c = .Range("1:1").Find(idStr, lookat:=xlWhole).Column
        c = Func.CountA(.Columns(c))
    End With
    If c > 1 Then GetCount = c - 1
    On Error GoTo 0
End Function
 
Last edited:

Harry_1234

New Member
Joined
Aug 19, 2017
Messages
31
Put code below in a NEW module and run Summarise2

Please confirm that the VALUES are correct
The code to exclude DID's will be posted later today or tomorrow
VBA Code:
Option Explicit

Private Summary As Worksheet, ws As Worksheet, Cel As Range, x As Long, y As Long
Private Func As WorksheetFunction
Private dID As New Collection, ValidNames As New Collection, Nm As String

Sub Summarise2()
    Application.ScreenUpdating = False
    Call Basics
    Call ValidSheets
    Call WriteColumnA
    Call WriteValues
End Sub
Private Sub Basics()
    Set Summary = Sheets("Summary")
    Set Func = WorksheetFunction
    Summary.Cells.Clear
End Sub
Private Sub ValidSheets()
    Set ValidNames = Nothing
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Summary", "Sheet1", "Check"         '(ignored)
            Case Else:  ValidNames.Add ws.Name
        End Select
    Next ws
End Sub
Private Sub WriteColumnA()
    Set dID = Nothing
        For x = 1 To ValidNames.Count
            On Error Resume Next
            For Each Cel In Sheets(ValidNames(x)).Range("1:1").SpecialCells(xlCellTypeConstants)
                dID.Add Cel.Text, Cel.Text
            Next Cel
            On Error GoTo 0
        Next x
    For x = 1 To dID.Count: Summary.Cells(x + 1, 1) = dID(x): Next
End Sub
Private Sub WriteValues()
    For x = 1 To ValidNames.Count
        Nm = ValidNames(x)
        Summary.Cells(1, x + 1) = Nm
        For y = 1 To dID.Count
            Summary.Cells(y + 1, x + 1) = GetCount(Nm, dID(y))
        Next y
    Next x
    Summary.Cells(1, 1).CurrentRegion.Offset(1).Sort Key1:=Summary.Cells(2, 1), Order1:=xlAscending
End Sub
Private Function GetCount(ByVal shName As String, ByVal idStr As String) As Variant
    Dim c As Long
    On Error Resume Next
    With Sheets(shName)
        c = .Range("1:1").Find(idStr, lookat:=xlWhole).Column
        c = Func.CountA(.Columns(c))
    End With
    If c > 1 Then GetCount = c - 1
    On Error GoTo 0
End Function
Hello,
Works like a charm. The values are correct.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,007
Office Version
365
Platform
Windows
You may not ultimately want it to run in this exact manner but follow these instructions for the first test

On sheet summary, insert an ActiveX command button
and change its caption to "Run Report
summary command button.jpg


Insert the code below in sheet "Summary" code window
(right click on sheet tab \ View Code \ paste code into that window
VBA Code:
Option Explicit
Const ZZ As String = "ZZ>"        'used in all subs, ZZ used to help with sorting later
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Selection.CountLarge > 1 Then Exit Sub
   
    Dim DIDs As Range: Set DIDs = Range("A1", Range("A" & Rows.Count).End(xlUp).Offset(-1)).Offset(1)
    If Not Intersect(Target, DIDs) Is Nothing Then
        Cancel = True
        Target.Value = ZZ & Target.Value
        Target.Value = Replace(Target.Value, ZZ & ZZ, "")
        Cells(1, 1).Activate
        With DIDs.Resize(, DIDs.CurrentRegion.Columns.Count)
        .Sort Key1:=Cells(2, 2), Order1:=xlAscending
        .Sort Key1:=Cells(2, 1), Order1:=xlAscending
        End With
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim Func As WorksheetFunction: Set Func = WorksheetFunction
    Dim c As Long, r As Long, x As Long, lastC As Long, rng As Range, cel As Range
    Application.ScreenUpdating = False
    Set rng = Sheets("Summary").Range("A1").CurrentRegion
    r = rng.Rows.Count + 1
    lastC = rng.Columns.Count
'copy values to new sheet
    With Sheets.Add(before:=Sheets(1))
        rng.Parent.Cells.Copy
        .Activate
        .Cells.PasteSpecial (xlPasteAll)
        .Cells.PasteSpecial (xlPasteColumnWidths)
        .Cells(1, 1).Select
'add totals
        With .Cells(r, 1).Resize(5)
            .Value = Func.Transpose(Array("   Included:", "", "   Excluded:", "", "   Total DIDs:"))
            .Font.Bold = True
        End With
        For c = 2 To lastC
            .Cells(r + 4, c) = Func.Sum(rng.Columns(c))
            .Cells(r + 2, c) = Func.SumIf(rng.Resize(, 1), ZZ & "*", rng.Columns(c))
            .Cells(r, c) = .Cells(r + 4, c) - .Cells(r + 2, c)
        Next c
'move total to correct line
        On Error Resume Next: x = .Range("A:A").Find(ZZ & "*").Row: On Error GoTo 0
        If x > 0 Then .Rows(r).Resize(2).Cut: .Cells(x, 1).Insert Shift:=xlDown
'remove ZZ
        For Each cel In .Range(rng.Address).Resize(rng.Rows.Count + 2, 1)
            cel.Value = Replace(cel.Value, ZZ, "")
        Next cel
    End With
End Sub
Use right-click to toggle values in column A
ZZ> is auto-inserted in front of items to be excluded (or removed if already listed for exclusion)

summary right-click.jpg


Run Summarise2 to generate the values in sheet "Summary"
(the procedure provided in previous post)

Click on Run Report
report is written to new sheet

summary result.jpg


Click on sheet "Summary"
note : excluded items have not been reset so that you can validate what was selected is correctly transferred to the report
exclude different items and run report again

Let me know how you get on and if there is anything that is not how you want it
 

Harry_1234

New Member
Joined
Aug 19, 2017
Messages
31
You may not ultimately want it to run in this exact manner but follow these instructions for the first test

On sheet summary, insert an ActiveX command button
and change its caption to "Run Report
View attachment 15689

Insert the code below in sheet "Summary" code window
(right click on sheet tab \ View Code \ paste code into that window
VBA Code:
Option Explicit
Const ZZ As String = "ZZ>"        'used in all subs, ZZ used to help with sorting later
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Selection.CountLarge > 1 Then Exit Sub
  
    Dim DIDs As Range: Set DIDs = Range("A1", Range("A" & Rows.Count).End(xlUp).Offset(-1)).Offset(1)
    If Not Intersect(Target, DIDs) Is Nothing Then
        Cancel = True
        Target.Value = ZZ & Target.Value
        Target.Value = Replace(Target.Value, ZZ & ZZ, "")
        Cells(1, 1).Activate
        With DIDs.Resize(, DIDs.CurrentRegion.Columns.Count)
        .Sort Key1:=Cells(2, 2), Order1:=xlAscending
        .Sort Key1:=Cells(2, 1), Order1:=xlAscending
        End With
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim Func As WorksheetFunction: Set Func = WorksheetFunction
    Dim c As Long, r As Long, x As Long, lastC As Long, rng As Range, cel As Range
    Application.ScreenUpdating = False
    Set rng = Sheets("Summary").Range("A1").CurrentRegion
    r = rng.Rows.Count + 1
    lastC = rng.Columns.Count
'copy values to new sheet
    With Sheets.Add(before:=Sheets(1))
        rng.Parent.Cells.Copy
        .Activate
        .Cells.PasteSpecial (xlPasteAll)
        .Cells.PasteSpecial (xlPasteColumnWidths)
        .Cells(1, 1).Select
'add totals
        With .Cells(r, 1).Resize(5)
            .Value = Func.Transpose(Array("   Included:", "", "   Excluded:", "", "   Total DIDs:"))
            .Font.Bold = True
        End With
        For c = 2 To lastC
            .Cells(r + 4, c) = Func.Sum(rng.Columns(c))
            .Cells(r + 2, c) = Func.SumIf(rng.Resize(, 1), ZZ & "*", rng.Columns(c))
            .Cells(r, c) = .Cells(r + 4, c) - .Cells(r + 2, c)
        Next c
'move total to correct line
        On Error Resume Next: x = .Range("A:A").Find(ZZ & "*").Row: On Error GoTo 0
        If x > 0 Then .Rows(r).Resize(2).Cut: .Cells(x, 1).Insert Shift:=xlDown
'remove ZZ
        For Each cel In .Range(rng.Address).Resize(rng.Rows.Count + 2, 1)
            cel.Value = Replace(cel.Value, ZZ, "")
        Next cel
    End With
End Sub
Use right-click to toggle values in column A
ZZ> is auto-inserted in front of items to be excluded (or removed if already listed for exclusion)

View attachment 15688

Run Summarise2 to generate the values in sheet "Summary"
(the procedure provided in previous post)

Click on Run Report
report is written to new sheet

View attachment 15690

Click on sheet "Summary"
note : excluded items have not been reset so that you can validate what was selected is correctly transferred to the report
exclude different items and run report again

Let me know how you get on and if there is anything that is not how you want it
Hello,
Thanks for your quick turnaround and all the help so far. I followed the above instructions and tested the result. All the values have appeared correctly and the exclusion works perfect. There are couple of minor additions I am hoping could be incorporated into this. Can the sum of Included for all sites be included in a separate column below (as shown in screen-shot). Similarly sum of excluded and sum of Total DID's. Also every time I run the report it creates a new sheet, can the same work-sheet be modified with the updated result just like the Summary page. I am open to creating a separate sheet called "DetailedSummary" and have "Run the report" from Summary page transpose results into the "DetailedSummary" sheet every time I run the report. I am just afraid that i might end up with way too many sheets if I don't do the housekeeping.
 

Attachments

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,007
Office Version
365
Platform
Windows
OOOPS!
Deleted by Yongle
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,007
Office Version
365
Platform
Windows
Ensure sheet "DetailedSummary" is in the wokbook before running

Please test code below
As the final step would you prefer everything to happen in the original summary sheet?

VBA Code:
Private Sub CommandButton1_Click()
    Dim Func As WorksheetFunction: Set Func = WorksheetFunction
    Dim c As Long, r As Long, x As Long, lastC As Long, rng As Range, cel As Range
    Application.ScreenUpdating = False
    Set rng = Sheets("Summary").Range("A1").CurrentRegion
    r = rng.Rows.Count + 1
    lastC = rng.Columns.Count
'copy values to new sheet
    With Sheets("DetailedSummary")
        .Cells.Clear
        rng.Parent.Cells.Copy
        .Activate
        .Cells.PasteSpecial (xlPasteAll)
        .Cells.PasteSpecial (xlPasteColumnWidths)
        .Cells(1, 1).Select
'add totals
        With .Cells(r, 1).Resize(8)
            .Value = Func.Transpose(Array("   Included:", "Sum of Included:", "", "   Excluded:", "Sum of Excluded:", "", "   Total DIDs:", "Sum of Total DIDs:"))
            .Font.Bold = True
        End With
        For c = 2 To lastC
            .Cells(r + 6, c) = Func.Sum(rng.Columns(c))
            .Cells(r + 3, c) = Func.SumIf(rng.Resize(, 1), ZZ & "*", rng.Columns(c))
            .Cells(r, c) = .Cells(r + 6, c) - .Cells(r + 3, c)
        Next c
            .Cells(r + 7, 2) = Func.Sum(.Cells(r + 6, 2).Resize(, lastC - 1))
            .Cells(r + 4, 2) = Func.Sum(.Cells(r + 2, 2).Resize(, lastC - 1))
            .Cells(r + 1, 2) = Func.Sum(.Cells(r, 2).Resize(, lastC - 1))
'move total to correct line
        On Error Resume Next: x = .Range("A:A").Find(ZZ & "*").Row: On Error GoTo 0
        If x > 0 Then .Rows(r).Resize(3).Cut: .Cells(x, 1).Insert Shift:=xlDown
'remove XXX
        For Each cel In .Range(rng.Address).Resize(rng.Rows.Count + 5, 1)
            cel.Value = Replace(cel.Value, ZZ, "")
        Next cel
    End With
End Sub
 

Harry_1234

New Member
Joined
Aug 19, 2017
Messages
31
Ensure sheet "DetailedSummary" is in the wokbook before running

Please test code below
As the final step would you prefer everything to happen in the original summary sheet?

VBA Code:
Private Sub CommandButton1_Click()
    Dim Func As WorksheetFunction: Set Func = WorksheetFunction
    Dim c As Long, r As Long, x As Long, lastC As Long, rng As Range, cel As Range
    Application.ScreenUpdating = False
    Set rng = Sheets("Summary").Range("A1").CurrentRegion
    r = rng.Rows.Count + 1
    lastC = rng.Columns.Count
'copy values to new sheet
    With Sheets("DetailedSummary")
        .Cells.Clear
        rng.Parent.Cells.Copy
        .Activate
        .Cells.PasteSpecial (xlPasteAll)
        .Cells.PasteSpecial (xlPasteColumnWidths)
        .Cells(1, 1).Select
'add totals
        With .Cells(r, 1).Resize(8)
            .Value = Func.Transpose(Array("   Included:", "Sum of Included:", "", "   Excluded:", "Sum of Excluded:", "", "   Total DIDs:", "Sum of Total DIDs:"))
            .Font.Bold = True
        End With
        For c = 2 To lastC
            .Cells(r + 6, c) = Func.Sum(rng.Columns(c))
            .Cells(r + 3, c) = Func.SumIf(rng.Resize(, 1), ZZ & "*", rng.Columns(c))
            .Cells(r, c) = .Cells(r + 6, c) - .Cells(r + 3, c)
        Next c
            .Cells(r + 7, 2) = Func.Sum(.Cells(r + 6, 2).Resize(, lastC - 1))
            .Cells(r + 4, 2) = Func.Sum(.Cells(r + 2, 2).Resize(, lastC - 1))
            .Cells(r + 1, 2) = Func.Sum(.Cells(r, 2).Resize(, lastC - 1))
'move total to correct line
        On Error Resume Next: x = .Range("A:A").Find(ZZ & "*").Row: On Error GoTo 0
        If x > 0 Then .Rows(r).Resize(3).Cut: .Cells(x, 1).Insert Shift:=xlDown
'remove XXX
        For Each cel In .Range(rng.Address).Resize(rng.Rows.Count + 5, 1)
            cel.Value = Replace(cel.Value, ZZ, "")
        Next cel
    End With
End Sub
Tested the code. The sum of Excluded always came out as 0 (see attached screen-shot). Apart from that, the rest worked fine. And yes ideally would prefer everything to happen in original Summary sheet.
 

Attachments

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,007
Office Version
365
Platform
Windows
oops!
Rich (BB code):
            .Cells(r + 4, 2) = Func.Sum(.Cells(r + 3, 2).Resize(, lastC - 1))
 

Watch MrExcel Video

Forum statistics

Threads
1,099,006
Messages
5,465,962
Members
406,457
Latest member
Pinky Rose Jordan

This Week's Hot Topics

Top