johnsonjl2
New Member
- Joined
- Nov 25, 2017
- Messages
- 1
I have used the following macro in the past to identify and delete subtotals = zero and their associated ranges. I'm subtotaling on changes in column q with values in column U. I am receiving a Run-time error '13': Type Mismatch and I do not know how to resolve this issue. Thanks for any help.
Sub FormatFile()
'
' FormatFile Macro
' Format and reconcile data from account detail report.
'
Application.ScreenUpdating = False
' Remove Subtotal from Export
Selection.End(xlDown).Select
Range("A1:U1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Rows("13767:13767").Select
' Sort and Subtotal File by Supplier/Employee
Selection.Delete Shift:=xlUp
Range("A16").Select
ActiveWorkbook.Worksheets("FNDWRR").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("FNDWRR").Sort.SortFields.Add Key:=Range( _
"Q16:Q13766"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("FNDWRR").Sort
.SetRange Range("A15:U13766")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.Subtotal GroupBy:=17, Function:=xlSum, TotalList:=Array(21), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
' Remove subtotals equal to zero and associated data.
Dim o As Integer, s As Integer, cell As Range
Dim z As String, cl As Range, frmcl As Range, cntr As Long
Dim sht As Worksheet
Set sht = Sheets("FNDWRR")
On Error Resume Next
Set frmcl = sht.UsedRange.SpecialCells(xlFormulas)
If frmcl Is Nothing Then GoTo 1
On Error GoTo 0
For Each cl In frmcl
cntr = 0
frm = cl.Formula
If InStr(frm, "SUBTOTAL") And Round(cl.Value, 2) = "0" Then
o = InStr(cl.Formula, ",")
s = InStr(cl.Formula, ")")
z = Mid(cl.Formula, o + 1, s - 1 - o)
For Each cell In sht.Range(z)
cntr = cntr + 1
Next cell
If cntr = Range(z).Count Then Range(z).ClearContents
cl.ClearContents
End If
Next cl
sht.[U:U].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' Remove subtotals.
Selection.RemoveSubtotal
' Format worksheet.
1: MsgBox "Could not find any formulae in the active sheet. Try Again."
End Sub
Sub FormatFile()
'
' FormatFile Macro
' Format and reconcile data from account detail report.
'
Application.ScreenUpdating = False
' Remove Subtotal from Export
Selection.End(xlDown).Select
Range("A1:U1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Rows("13767:13767").Select
' Sort and Subtotal File by Supplier/Employee
Selection.Delete Shift:=xlUp
Range("A16").Select
ActiveWorkbook.Worksheets("FNDWRR").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("FNDWRR").Sort.SortFields.Add Key:=Range( _
"Q16:Q13766"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("FNDWRR").Sort
.SetRange Range("A15:U13766")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.Subtotal GroupBy:=17, Function:=xlSum, TotalList:=Array(21), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
' Remove subtotals equal to zero and associated data.
Dim o As Integer, s As Integer, cell As Range
Dim z As String, cl As Range, frmcl As Range, cntr As Long
Dim sht As Worksheet
Set sht = Sheets("FNDWRR")
On Error Resume Next
Set frmcl = sht.UsedRange.SpecialCells(xlFormulas)
If frmcl Is Nothing Then GoTo 1
On Error GoTo 0
For Each cl In frmcl
cntr = 0
frm = cl.Formula
If InStr(frm, "SUBTOTAL") And Round(cl.Value, 2) = "0" Then
o = InStr(cl.Formula, ",")
s = InStr(cl.Formula, ")")
z = Mid(cl.Formula, o + 1, s - 1 - o)
For Each cell In sht.Range(z)
cntr = cntr + 1
Next cell
If cntr = Range(z).Count Then Range(z).ClearContents
cl.ClearContents
End If
Next cl
sht.[U:U].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' Remove subtotals.
Selection.RemoveSubtotal
' Format worksheet.
1: MsgBox "Could not find any formulae in the active sheet. Try Again."
End Sub