Combine Subtotal Macro

**Harlequin** · 10-04-2007, 07:41 AM

Hello

I have the following code to subtotal column B (Which are dates) for a location, in a worksheet called “IRDUB52”.

However, I have 3 other new locations, or worksheets now coming on (“IRDUB55”, “IRDUB60”, & “IRDUB65”).

Rather than have a separate macro for each one, by just changing the worksheet name, can all four of these locations / worksheets, be combined into the macro below so as I only have to press one macro, & not 4 individual macros?

Sub IRDUB52_Subtotal()
Dim Ctrl As String
  Ctrl = Application.Caller
  Dim LastRow As Long
  Dim NextMonth As String
  Dim R As Long
  Dim Rng As Range
  Dim ThisMonth As String
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("IRDUB52")
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Wks.Range(Cells(2, "A"), Cells(LastRow, "D"))
    
    Rng.Sort Key1:=Wks.Range("B1")
    R = 2
    
    With Wks
      Do While .Cells(R, "C").Value <> ""
       SubAmount = SubAmount + .Cells(R, "D").Count
       ThisMonth = Format(.Cells(R, "B"), "dd/mm/yyyy")
       NextMonth = Format(.Cells(R + 1, "B"), "dd/mm/yyyy")
          If ThisMonth <> NextMonth Then
             .Cells(R + 1, "B").EntireRow.Insert Shift:=xlShiftDown
               With .Cells(R + 1, "A")
                 .Value = "Count " & ThisMonth
                 .Font.Bold = True
               End With
               With .Cells(R + 1, "D")
                 .Font.Bold = True
                 .Value = SubAmount
               End With
             .Cells(R + 2, "B").EntireRow.Insert Shift:=xlShiftDown
             TotalAmount = TotalAmount + SubAmount
             SubAmount = 0
             R = R + 3
          Else
             R = R + 1
          End If
      Loop
      .Cells(R, "B").Value = "Total"
      .Cells(R, "B").Font.Bold = True
      .Cells(R, "D").Value = TotalAmount
      .Cells(R, "D").Font.Bold = True
      With .Range(.Cells(R - 1, "A"), .Cells(R - 1, "D"))
      
          End With
      End With
    
    
End Sub

Cheers

**JustinBram** · 10-04-2007, 07:59 AM

use this in the same workbook but make sure you have four sheets with your names “IRDUB52”, "IRDUB55”, “IRDUB60” and “IRDUB65” this will only work with each sheet being in the same format.

Sub IRDUB52_Subtotal()
Dim Ctrl As String
  Ctrl = Application.Caller
  Dim LastRow As Long
  Dim NextMonth As String
  Dim R As Long
  Dim Rng As Range
  Dim ThisMonth As String
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("IRDUB52")
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Wks.Range(Cells(2, "A"), Cells(LastRow, "D"))
    
    Rng.Sort Key1:=Wks.Range("B1")
    R = 2
    
    With Wks
      Do While .Cells(R, "C").Value <> ""
       SubAmount = SubAmount + .Cells(R, "D").Count
       ThisMonth = Format(.Cells(R, "B"), "dd/mm/yyyy")
       NextMonth = Format(.Cells(R + 1, "B"), "dd/mm/yyyy")
          If ThisMonth <> NextMonth Then
             .Cells(R + 1, "B").EntireRow.Insert Shift:=xlShiftDown
               With .Cells(R + 1, "A")
                 .Value = "Count " & ThisMonth
                 .Font.Bold = True
               End With
               With .Cells(R + 1, "D")
                 .Font.Bold = True
                 .Value = SubAmount
               End With
             .Cells(R + 2, "B").EntireRow.Insert Shift:=xlShiftDown
             TotalAmount = TotalAmount + SubAmount
             SubAmount = 0
             R = R + 3
          Else
             R = R + 1
          End If
      Loop
      .Cells(R, "B").Value = "Total"
      .Cells(R, "B").Font.Bold = True
      .Cells(R, "D").Value = TotalAmount
      .Cells(R, "D").Font.Bold = True
      With .Range(.Cells(R - 1, "A"), .Cells(R - 1, "D"))
      
          End With
      End With

    Set Wks = Worksheets("IRDUB55")
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Wks.Range(Cells(2, "A"), Cells(LastRow, "D"))
    
    Rng.Sort Key1:=Wks.Range("B1")
    R = 2
    
        With Wks
      Do While .Cells(R, "C").Value <> ""
       SubAmount = SubAmount + .Cells(R, "D").Count
       ThisMonth = Format(.Cells(R, "B"), "dd/mm/yyyy")
       NextMonth = Format(.Cells(R + 1, "B"), "dd/mm/yyyy")
          If ThisMonth <> NextMonth Then
             .Cells(R + 1, "B").EntireRow.Insert Shift:=xlShiftDown
               With .Cells(R + 1, "A")
                 .Value = "Count " & ThisMonth
                 .Font.Bold = True
               End With
               With .Cells(R + 1, "D")
                 .Font.Bold = True
                 .Value = SubAmount
               End With
             .Cells(R + 2, "B").EntireRow.Insert Shift:=xlShiftDown
             TotalAmount = TotalAmount + SubAmount
             SubAmount = 0
             R = R + 3
          Else
             R = R + 1
          End If
      Loop
      .Cells(R, "B").Value = "Total"
      .Cells(R, "B").Font.Bold = True
      .Cells(R, "D").Value = TotalAmount
      .Cells(R, "D").Font.Bold = True
      With .Range(.Cells(R - 1, "A"), .Cells(R - 1, "D"))
      
          End With
      End With

       Set Wks = Worksheets("IRDUB60")
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Wks.Range(Cells(2, "A"), Cells(LastRow, "D"))
    
    Rng.Sort Key1:=Wks.Range("B1")
    R = 2
    
        With Wks
      Do While .Cells(R, "C").Value <> ""
       SubAmount = SubAmount + .Cells(R, "D").Count
       ThisMonth = Format(.Cells(R, "B"), "dd/mm/yyyy")
       NextMonth = Format(.Cells(R + 1, "B"), "dd/mm/yyyy")
          If ThisMonth <> NextMonth Then
             .Cells(R + 1, "B").EntireRow.Insert Shift:=xlShiftDown
               With .Cells(R + 1, "A")
                 .Value = "Count " & ThisMonth
                 .Font.Bold = True
               End With
               With .Cells(R + 1, "D")
                 .Font.Bold = True
                 .Value = SubAmount
               End With
             .Cells(R + 2, "B").EntireRow.Insert Shift:=xlShiftDown
             TotalAmount = TotalAmount + SubAmount
             SubAmount = 0
             R = R + 3
          Else
             R = R + 1
          End If
      Loop
      .Cells(R, "B").Value = "Total"
      .Cells(R, "B").Font.Bold = True
      .Cells(R, "D").Value = TotalAmount
      .Cells(R, "D").Font.Bold = True
      With .Range(.Cells(R - 1, "A"), .Cells(R - 1, "D"))
      
          End With
      End With


    Set Wks = Worksheets("IRDUB65")
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Wks.Range(Cells(2, "A"), Cells(LastRow, "D"))
    
    Rng.Sort Key1:=Wks.Range("B1")
    R = 2
    
        With Wks
      Do While .Cells(R, "C").Value <> ""
       SubAmount = SubAmount + .Cells(R, "D").Count
       ThisMonth = Format(.Cells(R, "B"), "dd/mm/yyyy")
       NextMonth = Format(.Cells(R + 1, "B"), "dd/mm/yyyy")
          If ThisMonth <> NextMonth Then
             .Cells(R + 1, "B").EntireRow.Insert Shift:=xlShiftDown
               With .Cells(R + 1, "A")
                 .Value = "Count " & ThisMonth
                 .Font.Bold = True
               End With
               With .Cells(R + 1, "D")
                 .Font.Bold = True
                 .Value = SubAmount
               End With
             .Cells(R + 2, "B").EntireRow.Insert Shift:=xlShiftDown
             TotalAmount = TotalAmount + SubAmount
             SubAmount = 0
             R = R + 3
          Else
             R = R + 1
          End If
      Loop
      .Cells(R, "B").Value = "Total"
      .Cells(R, "B").Font.Bold = True
      .Cells(R, "D").Value = TotalAmount
      .Cells(R, "D").Font.Bold = True
      With .Range(.Cells(R - 1, "A"), .Cells(R - 1, "D"))
      
          End With
      End With
    
End Sub

lemme know how you get on

**JustinBram** · 10-04-2007, 08:02 AM

format wasn't the right word, layout is the right word

**Harlequin** · 10-04-2007, 09:16 AM

Sorry, that didn't work.

I attach a copy of the workbook with your code in it.

Cheers

**Harlequin** · 10-04-2007, 09:28 AM

Sorry.

I attach it now.

**Leith Ross** · 10-04-2007, 11:00 AM

Hello Harlequin,

Since the formatting, and data locations are the same on these sheets, the macro can be easily be modified to take the Worksheet name as an argument. Another macro can then call all 4 sheets using a command button.

Revised Macro

Sub SubtotalWorksheet(ByVal Worksheet_Name As String)

  Dim LastRow As Long
  Dim NextMonth As String
  Dim R As Long
  Dim Rng As Range
  Dim ThisMonth As String
  Dim Wks As Worksheet
  
    Set Wks = ThisWorkbook.Worksheets(Worksheet_Name)
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Wks.Range(Cells(2, "A"), Cells(LastRow, "D"))
    
    Rng.Sort Key1:=Wks.Range("B1")
    R = 2
    
    With Wks
      Do While .Cells(R, "C").Value <> ""
       SubAmount = SubAmount + .Cells(R, "D").Count
       ThisMonth = Format(.Cells(R, "B"), "dd/mm/yyyy")
       NextMonth = Format(.Cells(R + 1, "B"), "dd/mm/yyyy")
          If ThisMonth <> NextMonth Then
             .Cells(R + 1, "B").EntireRow.Insert Shift:=xlShiftDown
               With .Cells(R + 1, "A")
                 .Value = "Count " & ThisMonth
                 .Font.Bold = True
               End With
               With .Cells(R + 1, "D")
                 .Font.Bold = True
                 .Value = SubAmount
               End With
             .Cells(R + 2, "B").EntireRow.Insert Shift:=xlShiftDown
             TotalAmount = TotalAmount + SubAmount
             SubAmount = 0
             R = R + 3
          Else
             R = R + 1
          End If
      Loop
      .Cells(R, "B").Value = "Total"
      .Cells(R, "B").Font.Bold = True
      .Cells(R, "D").Value = TotalAmount
      .Cells(R, "D").Font.Bold = True
      'With .Range(.Cells(R - 1, "A"), .Cells(R - 1, "D"))
      
         
      'End With
       
End Sub

Macro to Call Multiple Worksheets

Sub SubTotalSheets()

  SubtotalWorksheet "IRDUB52" 
  SubtotalWorksheet "IRDUB55" 
  SubtotalWorksheet "IRDUB60" 
  SubtotalWorksheet "IRDUB65"

End Sub

SIncerely,
Leith Ross