Avatar of Ayansane
Flag for Guinea

asked on 

I get this error ['1004' Method Range' of Object _Worksheet' Failed] when try to run

Hi All,

I need to print tables from ranges where the SubTotal is not equal to zero.  In specific cells.

I get a Run-Time Error ['1004' Method Range' of Object _Worksheet' Failed ] when I try running the code below.
It was working ok, but I needed to add a portion in blue to reference the right Print Areas...
Any help welcome as I'm feverishly working on this file. Thank you, thank you.

Sub PrintCDivSum() 'von saerdna
Dim SaveActivePrinter As String
Dim DictC As Object 'Scripting.Dictionary
Dim DictP As Object 'Scripting.Dictionary
Dim SheetName As Variant, ThisSheet As Worksheet, ThisRange As Range
Dim SheetsToPrint As Variant, i As Long

SaveActivePrinter = Application.ActivePrinter
Select Case MsgBox("Print to " & SaveActivePrinter & "?", vbYesNoCancel, "PrintCDivSum")
Case vbYes
Case vbNo
'Choose a printer
If Not Application.Dialogs(xlDialogPrinterSetup).Show Then Exit Sub
Case vbCancel
Exit Sub
End Select

Set DictC = CreateObject("Scripting.Dictionary")
DictC.CompareMode = vbTextCompare
' SheetName, Cells for zero check
DictC.Add "GC's", "AI65,AI166"
DictC.Add "DIV 2", "AN65,AN166,AN268,AN370,AN472,AN778,AN880,AN982,AN1084"
DictC.Add "DIV 3", "AN65,AN166,AN268,AN370,AN472,AN778,AN880,AN982,AN1084"
DictC.Add "DIV 4", "AN65,AN166,AN268,AN370,AN472"
DictC.Add "DIV 5", "AN65,AN166"
DictC.Add "DIV 6", "AN65,AN166"
DictC.Add "DIV 7", "AN65,AN166,AN268,AN370,AN472,AG5:AP65,AG5:AP472,AG205:AP268"
DictC.Add "DIV 8", "AN65,AN166"
DictC.Add "DIV 9", "AN65,AN166,AN268,AN370,AN472,AN778"
DictC.Add "DIV 10", "AN65,AN166"
DictC.Add "DIV 14", "AN65"
DictC.Add "DIV 15", "AN65,AN166,AN268"
DictC.Add "DIV 16", "AN65"

Set DictP = CreateObject("Scripting.Dictionary")
DictP.CompareMode = vbTextCompare
' SheetName, PrintArea
DictP.Add "GC's", "11a,12a"
DictP.Add "DIV 2", "13a,14a,15a,16a,17a,18a,19a,110a,111a,112a,113a"
DictP.Add "DIV 3", "l14a,l15a,l16a,l17a,l18a" '_SHT14,_SHT15,_SHT16,_SHT17,_SHT18"
DictP.Add "DIV 4", "l19A" '_SHT19"
DictP.Add "DIV 5", "l20a,l21a" '_SHT20,_SHT21"
DictP.Add "DIV 6", "l22a,l23a" '_SHT22,_SHT23"
DictP.Add "DIV 7", "l24a,l25a,l26a,l27a,l28a" '_SHT24,_SHT25,_SHT26,_SHT27,_SHT28"
DictP.Add "DIV 8", "l29a,l30a" '_SHT29,_SHT30"
DictP.Add "DIV 9", "l31a,l32a,l33a,l34a,l35a,l36a" '_SHT31,_SHT32,_SHT33,_SHT34,_SHT35,_SHT36"
DictP.Add "DIV 10", "l37a,l38a" '_SHT37,_SHT38"
DictP.Add "DIV 14", "l39A" '_SHT39"
DictP.Add "DIV 15", "l40A,l41a,l42a" '_SHT40,_SHT41,_SHT42"
DictP.Add "DIV 16", "l43A" '_SHT43"

ReDim SheetsToPrint(1 To Sheets.Count)

'Each key in the dictionary is a sheet name
For Each SheetName In DictC.Keys
'Refer to the sheet
Set ThisSheet = Worksheets(SheetName)
With ThisSheet
'Refer to the cells
Set ThisRange = .Range(DictC.Item(SheetName))
'Skip if zero
If WorksheetFunction.Sum(ThisRange) <> 0 Then
'Add to print queue
i = i + 1
SheetsToPrint(i) = SheetName
'Set print area if any
If DictP.Exists(SheetName) Then
Set ThisRange = .Range(DictP.Item(SheetName))
.PageSetup.PrintArea = ThisRange.Address
End If
End If
End With

'Print if necessary
If i > 0 Then
ReDim Preserve SheetsToPrint(1 To i)
Set ThisSheet = ActiveSheet
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End If

Application.ActivePrinter = SaveActivePrinter
End Sub
Microsoft ExcelVisual Basic ClassicMicrosoft Office

Avatar of undefined
Last Comment
Roy Cox

8/22/2022 - Mon