• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Changing the way this code copies ranges to to a worksheet and prints

Skeeeter56

New Member
This code works perfectly, it loops through 14 columns looking for value in 1 of 5 rows. Each of the 5 rows have a group of Named ranges. If the value is True, it copies 3 ranges in same column to 1 of 5 worksheets and then prints, it then loops back again and repeats till complete. This runs when a button is clicked and if all columns had True would print 70 sheets.

I have another button for if the value is False; it will also copy the ranges and print but a little bit differently
It loops through 14 columns looking for the False value in each row, and at end of each row it then Prints. Once again there 1 of 5 worksheets these are formatted with 3 pages each this allows if there is a value in all, which will be very rare.

Each row has a set of ranges they are

Row 23 Nuna1 to Nuna14
Row 31 Verm1 to Verm14
Row 43 Mitch 1 to Mitch14
Row 58 Black1 to Black14
Row 78 Boxhill1 to Boxhill14

So at the completion of each row it prints the worksheet and then goes to next row. I have included a screenshot of 1 of these worksheets I have typed in where I want the data that is copied, this matches what I have in the workbook currently. Here if all columns had False needs to print 5 Worksheets each with up to 3 pages that's 15 pages.

I hope this makes sense I have been playing with this for about a week
70298

This is the code
Code:
Private Sub cboPrintBus_Click()
Dim shData As Worksheet, shGroup As Worksheet
  Dim arrSh As Variant, arrCe As Variant, arrRn As Variant, arrCl As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
 
  Application.ScreenUpdating = False
  arrSh = Array("Nunawading Bus", "Vermont Bus", "Mitcham Bus", "Blackburn Bus", "Box Hill Bus") 'Names of the 5 destinations Sheets
  arrCe = Array(23, 33, 43, 58, 78) 'Rows where arrRn ranges are located,
  arrRn = Array("Nuna", "Verm", "Mitch", "Black", "Boxhill") 'The ranges that get copied and each have a number like Nuna1 through to Last Nuna14
  arrNm = Array("Name")
  arrCo = Array("Code")
  arrCl = Array("Clear7", "Clear8", "Clear9", "Clear10", "Clear11") 'This clears the Destinations sheets after Printing is complete
 
 
  Set shData = ThisWorkbook.Worksheets("Week Commencing")
  For i = 0 To UBound(arrSh)
    Set shGroup = Sheets(arrSh(i))
    k = 1
    For j = Columns("D").Column To Columns("Q").Column
      If shData.Cells(arrCe(i), j) = False Then
        shData.Range(arrRn(i) & k).Copy
        lr = 5
        shGroup.Range("B7").PasteSpecial Paste:=xlPasteValues
        
        shData.Range(arrNm(0) & k).Copy
            
            shGroup.Range("C4").PasteSpecial Paste:=xlPasteValues
            
        shData.Range(arrCo(0) & k).Copy
            
            shGroup.Range("C5").PasteSpecial Paste:=xlPasteValues
      'MsgBox Printed
      shGroup.PrintPreview
      
      End If
      k = k + 1
    Next j
  Next i
 
  For i = 0 To UBound(arrSh)
    Set shGroup = Sheets(arrSh(i))
    shGroup.Range(arrCl(i)).ClearContents
  Next i
 
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub
 

Attachments

  • Weekly UMS Template Version 4.xlsm
    238.1 KB · Views: 0
Back
Top