troubleshooting Question

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

Avatar of Ayansane
AyansaneFlag for Guinea asked on
Microsoft ExcelVisual Basic ClassicMicrosoft Office
22 Comments2 Solutions579 ViewsLast Modified:
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.

/code
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
'Okay
Case vbNo
'Choose a printer
If Not Application.Dialogs(xlDialogPrinterSetup).Show Then Exit Sub
Case vbCancel
'Abort
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
Next

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

Application.ActivePrinter = SaveActivePrinter
End Sub
/code
ASKER CERTIFIED SOLUTION
Roy Cox
Group Finance Manager

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Join our community to see this answer!
Unlock 2 Answers and 22 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 2 Answers and 22 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros