We help IT Professionals succeed at work.
Get Started

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

561 Views
Last Modified: 2016-03-29
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
Comment
Watch Question
Group Finance Manager
CERTIFIED EXPERT
Commented:
This problem has been solved!
Unlock 2 Answers and 22 Comments.
See Answers
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant

An Experts Exchange subscription includes unlimited access to online courses.

Get Started
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE