Posts by ArbeitWali

ArbeitWali · Mar 14th 2016

Hi All,

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

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

/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

Display More