Input subtotal for worksheets at selected cell by using InputBox

0

Dear All,

I have the following macro to insert subtotal to a worksheets. It work perfectly.

In the existing macro , SubTotal is inserted at Range("E4 ')

I want the help to modify the macro that

  1. can work for all worksheets
  2. Subtotal placed at selected cell by using input box.(Default Range("E4").
  3. Cell for subtotal formula is the same for all worksheets
  4. No repeated inputbox for different worksheets

Looking forward to having your suggestion in this regards

Best Regards

Arsil Hadjar

Sub InsertSUBTOTAL()
  Dim lastRow As Long
  lastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row - 1
  Range("E4").Select
  ActiveCell.FormulaR1C1 = "=SUBTOTAL(3,R[2]C:R[" & lastRow & "]C)"
  End Sub
Answer
Discuss

Answers

0
Selected Answer

Please try this code. It should be installed in a standard code module (none of the default modules Excel creates automatically but one which you ahve to insert, by default Module1 - rename to your preference).

Option Explicit
Sub InsertSUBTOTAL()
    ' 09 Aug 2018
    
    Static Target As Range
    Dim TargetAddress As String
    Dim LastCell As Range
    
    Do While Target Is Nothing
        TargetAddress = InputBox("Enter the cell address in which to display the COUNTA subtotal:", , "E4")
        If TargetAddress = "" Then Exit Sub
        On Error Resume Next
        Set Target = Range(TargetAddress)
        If Err Or (Target.Cells.Count > 1) Then
            MsgBox "Please enter a valid address of a single cell.", _
                    vbExclamation, "Invalid cell address"
            Set Target = Nothing
        End If
    Loop
    
    On Error GoTo 0
    With Target
        With .Worksheet
            Set LastCell = .Cells(.Rows.Count, Target.Column).End(xlUp)
        End With
        TargetAddress = Range(.Offset(2), LastCell).Address
        .Formula = "=SUBTOTAL(3," & TargetAddress & ")"
    End With
End Sub

Note that the code counts entries in the column specified by InputBox from 2 rows below the specified cell to the last used cell in that same column, including the last cell itself. The code will remember the address entered once and will forget it when the workbook is closed. To further automate the action I suggest you add the code below to the code sheet of each worksheet on which you want to have the above action.

Private Sub Worksheet_Activate()
    ' 09 Aug 2018
    InsertSUBTOTAL
End Sub

If there already is a procedure by the same name in that module, just add the call  InsertSUBTOTAL (single, separate line) at the bottom of the existing procedure, above the existing End Sub. The effect of this addition is that the formula will be refreshed to include possible additions to or deletions from the count range whenever the sheet is activated. Since the code remembers the cell to refresh you wouldn't be aware of the updating.

EDIT 09 Aug 2018   =================================

The code below is a variation of the above which sets the subtotal in all worksheets in one go.

Option Explicit
Sub InsertSUBTOTAL()
    ' 09 Aug 2018
   
    Dim Target As Range
    Dim TargetAddress As String
    Dim FirstCell As Range, LastCell As Range
    Dim Ws As Worksheet
   
    Do While Target Is Nothing
        TargetAddress = InputBox("Enter the cell address in which to display the COUNTA subtotal:", , "E4")
        If TargetAddress = "" Then Exit Sub
        On Error Resume Next
        Set Target = Range(TargetAddress)
        If Err Or (Target.Cells.Count > 1) Then
            MsgBox "Please enter a valid address of a single cell.", _
                    vbExclamation, "Invalid cell address"
            Set Target = Nothing
        End If
    Loop
   
    On Error GoTo 0
    For Each Ws In ThisWorkbook.Worksheets
        With Ws
            Set FirstCell = .Range(TargetAddress).Offset(2)
            Set LastCell = .Cells(.Rows.Count, Target.Column).End(xlUp)
            .Range(TargetAddress).Formula = "=SUBTOTAL(3," & Range(FirstCell, LastCell).Address & ")"
        End With
    Next Ws
End Sub
Discuss

Discussion

Dear Variatus,

Many thanks for the code.

It works on active sheets.

To do with other sheets, I need activate the other sheets and repeating the macro again,

Is it possible to run the macros for all worksheets at onces with only one time Inputbox to defined the subtotal cell address (Note: SubTotal cell address for other sheets also the same) ?

So when the macro is running, all the worksheets will have the subtotal on the same cell without the need for repeating inputbox for different worksheets

Looking forward to having your further advice in this regards

Best regards
Arsil Hadjar
Arsil (rep: 10) Aug 9, '18 at 12:10 am
Dear Variatus,
I have tried to run the macro which sets the subtotal in all worksheets in one go.
Unfortunately , there was an compile errorr which says : Method or data member not found

at the following point
.formula = "=SUBTOTAL(3," & Range(FirstCell, LastCell).Address & ")"  

How to solve this issues?

Best regards
Arsil Hadjar
Arsil (rep: 10) Aug 9, '18 at 9:31 pm
Hi Arsil, I had omitted to update that line. Sorry about that. The error has been corrected in the post above.
Variatus (rep: 1595) Aug 10, '18 at 2:47 am
Dear Variatus,

Just one thing.
The macro can work if it is installed in the workbooks modules.
But it failed to run if I put the macro from my personal macro workbooks(Personal.xlsb). Why ???

Best regards
Arsil Hadjar
,
Arsil (rep: 10) Aug 10, '18 at 4:01 am
Hello Arsil,
Look for the line For Each Ws In ThisWorkbook.Worksheets. Replace ThisWorkbook with ActiveWorkbook.
Regards,
Variatus (rep: 1595) Aug 10, '18 at 4:42 am
Dear Variatus,
Many thanks for the solution.
It works

Best regards
Arsil Hadjar
Arsil (rep: 10) Aug 12, '18 at 8:26 pm
Hello Arsil, Now that you can run the code on any workbook its capability for doing unwanted damage has increased exponentially. A good way to limit the risk is to create a button in the workbooks in which it should run and make it a point to never call the macro in any other way.
Good luck!
Variatus (rep: 1595) Aug 12, '18 at 9:24 pm
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login