Update VBA Code for Split and Total

R

ravi2628

Board Regular
Joined
Dec 20, 2017
Messages
221
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi Friends,

good morning/afternoon/eveing/night.

I have the following code to split the data into multiple sheets but I want to add a total in the last row.

can anyone please help to add the additional line of code to work?.

But total column may not be fixed every time so I need to specify the column/columns
VBA Code: 
Option Explicit
Sub FilterFixedColumn()
    Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim FilterCol As Variant, FilterValue As Variant
    Dim SheetName As String
   
    On Error GoTo progend
'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
   
'Column you are filtering
    FilterCol = "A"
   
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
   
    With wsData
        .Activate
'add password if needed
        .Unprotect Password:=""
       
        Set Datarng = .Range("A1").CurrentRegion
       
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsFilter.Range("A1"), Unique:=True
       
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
       
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
             FilterValue = FilterRange.Value
'USA date format required for filter
             If IsDate(FilterValue) Then FilterValue = Format(FilterValue, "mm/dd/yyyy")

'exact matches only
                wsFilter.Range("B2").Formula = "=" & """=" & FilterValue & """"
               
'date selection - replace illegal "/" character
                SheetName = Replace(FilterValue, "/", "-")
               
'ensure tab name limit not exceeded
                SheetName = Trim(Left(SheetName, 31))
               
'check if sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
                End If
'set object variable to sheet
                Set wsNames = Worksheets(SheetName)
'clear sheet
                wsNames.UsedRange.Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If
'autofit columns
            wsNames.UsedRange.Columns.AutoFit
'clear from memory
            Set wsNames = Nothing
        Next
        .Select
    End With
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then
        MsgBox (Error(Err)), vbCritical, "Error"
        Err.Clear
    End If
End Sub




Thanks In advance

Regards,
Ravi
 
Last edited by a moderator:

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Sort by date Sort by votes
I am a bit unclear on which column you want to add a total.
If you want it on the last column then if you add the below before the line
' autofit column
It should work.
Note: change offset to 1 if you don't want a blank line before the total

VBA Code: 
            Dim lastColNames As Long
            Dim lastRowNames As Long
            lastColNames = wsNames.Cells(1, Columns.Count).End(xlToLeft).Column
            lastRowNames = wsNames.Cells(Rows.Count, lastColNames).End(xlUp).Row
            wsNames.Cells(lastRowNames, lastColNames).Offset(2, 0).Formula = _
                                    "=Sum(" & wsNames.Cells(2, lastColNames).Address & ":" & _
                                                wsNames.Cells(lastRowNames, lastColNames).Address & ")"
 
Upvote 0
Alex Blakenburg said:
I am a bit unclear on which column you want to add a total.
If you want it on the last column then if you add the below before the line
' autofit column
It should work.
Note: change offset to 1 if you don't want a blank line before the total

VBA Code: 
            Dim lastColNames As Long
            Dim lastRowNames As Long
            lastColNames = wsNames.Cells(1, Columns.Count).End(xlToLeft).Column
            lastRowNames = wsNames.Cells(Rows.Count, lastColNames).End(xlUp).Row
            wsNames.Cells(lastRowNames, lastColNames).Offset(2, 0).Formula = _
                                    "=Sum(" & wsNames.Cells(2, lastColNames).Address & ":" & _
                                                wsNames.Cells(lastRowNames, lastColNames).Address & ")"
Click to expand...
as Sample data.

Book2
ABCDEFGHIJ
21EmployeeExpenditure1Expenditure2Expenditure3Expenditure4Expenditure5Expenditure6Expenditure7Expenditure8Expenditure9
22Ravi830765260718103507733926065230370371685664432
23Ravi721744354451158683963740537886138363143135919
24Ravi55063371451681649033864472060496170163292125
25Ravi370739478820077562039993221634735818954685121
26Ravi496507886995626853887029759200626327057524326
27Ravi14416936934269136712820110052499051443121991
28Ravi343688985181314896541995740347981466572358380
29Ravi383259668091810974956612832410222383560836519
30Raj96206126676757561916426270227971272422442628
31Raj902994833723598296632107672207386546597361279
32Raj6615538416919495661321842111317232417766967
33Raj132747266945268806352754763070773906089683131
34Raj932836818390722659582438513543449604899389
35Raj614627357884435577952091461141617797568750077
36Raj1912716705428702390662472810152074271877332
37Raj863598016125806373993344578328834004698796176
Sheet2



like some times Columns will start from B or H or maybe from B:J

I need to select the range of columns manually through a dialog box if possible.

and also where I need to insert the new code of lines in my macro please suggest.
 
Upvote 0
Try this on a copy of your workbook.

VBA Code: 
Sub FilterFixedColumn()
    Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim FilterCol As Variant, FilterValue As Variant
    Dim SheetName As String
   
    On Error GoTo progend
'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
   
'Column you are filtering
    FilterCol = "A"
   
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
   
    With wsData
        .Activate
' XXX Added for selecting Columns to total
        Dim rngTotCols As Range
        Dim rCol As Range
        Dim rngTotCols As Range
        Dim lastRowNames As Long
        Dim ColtoTotal  As Long
            
        On Error Resume Next
        Set rngTotCols = Application.InputBox(Prompt:="Select Columns to Total " & vbLf & _
                                                    "Select by Mouse or Type (eg B:E) Columns", Type:=8)
        On Error GoTo 0
        If rngTotCols Is Nothing Then Exit Sub
' XXX End of Added for selecting Columns to total
        
'add password if needed
        .Unprotect Password:=""
       
        Set Datarng = .Range("A1").CurrentRegion
       
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsFilter.Range("A1"), Unique:=True
       
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
       
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
             FilterValue = FilterRange.Value
'USA date format required for filter
             If IsDate(FilterValue) Then FilterValue = Format(FilterValue, "mm/dd/yyyy")

'exact matches only
                wsFilter.Range("B2").Formula = "=" & """=" & FilterValue & """"
               
'date selection - replace illegal "/" character
                SheetName = Replace(FilterValue, "/", "-")
               
'ensure tab name limit not exceeded
                SheetName = Trim(Left(SheetName, 31))
               
'check if sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
                End If
'set object variable to sheet
                Set wsNames = Worksheets(SheetName)
'clear sheet
                wsNames.UsedRange.Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If
            
' XXX Added for selecting Columns to total
            lastRowNames = wsNames.Cells(Rows.Count, "A").End(xlUp).Row
            
            For Each rCol In rngTotCols.Columns
                ColtoTotal = rCol.Column
                wsNames.Cells(lastRowNames, ColtoTotal).Offset(2, 0).Formula = _
                                        "=Sum(" & wsNames.Cells(2, ColtoTotal).Address & ":" & _
                                                    wsNames.Cells(lastRowNames, ColtoTotal).Address & ")"
            Next rCol
' XXX End of Added for selecting Columns to total
            
'autofit columns
            wsNames.UsedRange.Columns.AutoFit
'clear from memory
            Set wsNames = Nothing
        Next
        .Select
    End With
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then
        MsgBox (Error(Err)), vbCritical, "Error"
        Err.Clear
    End If
End Sub
 
Upvote 0
Solution
Hi, according to the attachment this is the part to add to the code after the advanced filter :​
VBA Code: 
                With wsNames.[A1].CurrentRegion
                    With .Cells(.Rows.Count + 1, 2).Resize(, .Columns.Count - 1)
                         .Borders(8).Weight = 2
                         .Formula = "=SUM(B2:B" & .Row - 1 & ")"
                    End With
                End With
 
Upvote 0
Alex Blakenburg said:
Try this on a copy of your workbook.

VBA Code: 
Sub FilterFixedColumn()
    Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim FilterCol As Variant, FilterValue As Variant
    Dim SheetName As String
  
    On Error GoTo progend
'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
  
'Column you are filtering
    FilterCol = "A"
  
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
  
    With wsData
        .Activate
' XXX Added for selecting Columns to total
        Dim rngTotCols As Range
        Dim rCol As Range
        Dim rngTotCols As Range
        Dim lastRowNames As Long
        Dim ColtoTotal  As Long
           
        On Error Resume Next
        Set rngTotCols = Application.InputBox(Prompt:="Select Columns to Total " & vbLf & _
                                                    "Select by Mouse or Type (eg B:E) Columns", Type:=8)
        On Error GoTo 0
        If rngTotCols Is Nothing Then Exit Sub
' XXX End of Added for selecting Columns to total
       
'add password if needed
        .Unprotect Password:=""
      
        Set Datarng = .Range("A1").CurrentRegion
      
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsFilter.Range("A1"), Unique:=True
      
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
      
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
             FilterValue = FilterRange.Value
'USA date format required for filter
             If IsDate(FilterValue) Then FilterValue = Format(FilterValue, "mm/dd/yyyy")

'exact matches only
                wsFilter.Range("B2").Formula = "=" & """=" & FilterValue & """"
              
'date selection - replace illegal "/" character
                SheetName = Replace(FilterValue, "/", "-")
              
'ensure tab name limit not exceeded
                SheetName = Trim(Left(SheetName, 31))
              
'check if sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
                End If
'set object variable to sheet
                Set wsNames = Worksheets(SheetName)
'clear sheet
                wsNames.UsedRange.Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If
           
' XXX Added for selecting Columns to total
            lastRowNames = wsNames.Cells(Rows.Count, "A").End(xlUp).Row
           
            For Each rCol In rngTotCols.Columns
                ColtoTotal = rCol.Column
                wsNames.Cells(lastRowNames, ColtoTotal).Offset(2, 0).Formula = _
                                        "=Sum(" & wsNames.Cells(2, ColtoTotal).Address & ":" & _
                                                    wsNames.Cells(lastRowNames, ColtoTotal).Address & ")"
            Next rCol
' XXX End of Added for selecting Columns to total
           
'autofit columns
            wsNames.UsedRange.Columns.AutoFit
'clear from memory
            Set wsNames = Nothing
        Next
        .Select
    End With
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then
        MsgBox (Error(Err)), vbCritical, "Error"
        Err.Clear
    End If
End Sub
Click to expand...
Hi Alex

i have copied the code and pasted it in my module but I was getting the following error as per attachement.
1633079200671.png
 
Upvote 0

ravi2628​

I got the Macro perfectly but I was not getting the cell value as total in the last
Click to expand...
I don't know what that means.

Did you get an input box ?
What did you put in the input box ?
Did you get totals in any of the column on the output sheet ?

If there is not much data in your output can you do an XL2BB or picture of your output.
If there is a lot of data can you show me the Top of the sheet with Column and Row references and also the bottom with Column and Row references.
 
Upvote 0
You must log in or register to reply here.

Similar threads

pliskers
  • Question Question
Loop to create separate filtered tabs from a master data set
Replies
4
Views
871
pliskers
pliskers
Guna13
  • Question Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
391
Guna13
Guna13
H
  • Solved
stop add new sheet when split data into multiple sheets when run macro repeatedly
Replies
3
Views
650
dmt32
D
V
  • Question Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
523
VanGirl
V
K
  • Question Question
VBA to filter Worksheet on manager column & copy all data to new workbook
Replies
8
Views
1K
kizzie37
K

Forum statistics

Threads
1,223,894
Messages
6,175,254
Members
452,623
Latest member
Techenthusiast

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top