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
Thanks In advance
Regards,
Ravi
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: