The original code works when you click a button it loops through 70 Ranges in 5 groups with 14 columns per group. A formula is used to see if the result is True, False or 1. The code loops through 5 rows checking what the value is in each of the 14 columns. If it is true it copies several ranges to 1 of 5 Worksheets and then prints. the loops back moving across and down till it completes.
The data is added weekly and may on have 1 item that is true or false, or may have 20. My formula that decides if the value is True or False if has no data returns a 1 so that it is skipped.
What I need is for some help with this code so that it does the same thing, only difference is the code copies to differently formatted worksheets. The original if it finds true it then copies 3 ranges to a worksheet and then prints and then loops to next. With this one there are 14 columns per group and I need what ever is False to print onto only 1 worksheet which has 3 pages and is formatted with 5 locations per page to paste the copied ranges to and when finished with that group print this worksheet then go to next group.
Below is a screenshot of 1 of the 5 worksheets which I have typed where I want the ranges to be copied to. The 5 sheets are all the same format, the only difference is the number of rows they each have. I hope I have explained as best as I can, I hope someone is able to assist.
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(21, 31, 41, 56, 75, 77) '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
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
Hi Peter,
Sorry for the late reply.
Try this:
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(21, 31, 41, 56, 75, 77) '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
Dim col As Byte, rw As Byte, off As Byte
rw = 4 'for first 5 items; will be 26 for next 5 and 52 for last 4
col = 3 ' column C for first 5, increase with 2 columns step, reset to column C each 5 items
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
shGroup.Cells(rw, col).Value = shData.Range(arrNm(0) & k).Value
shGroup.Cells(rw + 1, col).Value = shData.Range(arrCo(0) & k).Value
shGroup.Range(shGroup.Cells(rw + 3, col - 1), shGroup.Cells(rw + 3 + shData.Range(arrRn(i) & k).Cells.Count - 1, col - 1)).Value = shData.Range(arrRn(i) & k).Value
col = col + 2
'reset row and col at each 5 items
If j = 6 Then
rw = 26
col = 3
End If
If j = 11 Then
rw = 52
col = 3
End If
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
Wow yes this does work and copies and pastes to correct location, only issue it seems is that it does the PrintPreview on each loop.
As there are 14 columns that could have false, could mean that 14 ranges are pasted on to the same worksheet. So when it completes the loop before moving onto next Value row in Array arrCe and Sheet in Array arrSh it prints 1,2 or 3 sheets depending on how many falses it finds.
I would like to thank you so much, I have spent about 1 month working on trying to get somewhere with this, this is so close.
That's where you had the printpreview line, made no change to that.
Move it between Next j and Next i (between the 14 columns loop and the sheets loop) if you want to see that only once per sheet.
Yes I have tried that and it does print the sheet after the 14 column loop, but then prints a blank sheet for each of the sheets that no values have been copied and pasted. So guess a bit more code is need if the sheet is blank which I guess could be checked if a value is in the first paste on the sheet if empty do not print.
Initially it did seem to work correctly but now that have spent some time checking it few issues.
I have put more data in, but is not working as it should, I have tried various things to no avail.
I have uploaded this copy
Catalin Bombea said
That's where you had the printpreview line, made no change to that.Move it between Next j and Next i (between the 14 columns loop and the sheets loop) if you want to see that only once per sheet.
Hi I have almost got this all working, I got the code to check is cell C3 is blank if it is does not Print. So now it does not print any blank sheets.
I am having a issue with going to next page thou, as it was checking value of J. There is a Value in all 14 locations and it on each Next J it would increase by 1.
I have changed it to check the value of Col,
If col = 13 Then
rw = 24
col = 3
This correctly moves to page 2 But as it set Col back to 3 I do not know how can get it to go to 3rd page as
If col = 13 Then
rw = 50
col = 3
This will not work as Col starts at 3 and on each loop that false is found adds 2, so needs to go to next page at 13 again,
I have spent last few weeks but cannot find a way, hope you able to assist me with this as I think then the code is complete
Peter Douglas said
Hi I have almost got this all working, I got the code to check is cell C3 is blank if it is does not Print. So now it does not print any blank sheets.
I am having a issue with going to next page thou, as it was checking value of J. There is a Value in all 14 locations and it on each Next J it would increase by 1.
I have changed it to check the value of Col,
If col = 13 Then
rw = 24
col = 3This correctly moves to page 2 But as it set Col back to 3 I do not know how can get it to go to 3rd page as
In the version provided earlier, the code will print the first 5 in page1, next 5 in page 2, and the remaining 4 on page 3.
I think that you are trying to say (and not saying) is that you want the first 5 filled, and go to the next page only when all 5 are filled in the current page.
Add a counter, don't rely on col:
Dim col As Byte, rw As Byte, off As Byte, Counter As Byte
rw = 4 'for first 5 items; will be 26 for next 5 and 52 for last 4
col = 3 ' column C for first 5, increase with 2 columns step, reset to column C each 5 items
Counter = 1
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
shGroup.Cells(rw, col).Value = shData.Range(arrNm(0) & k).Value
shGroup.Cells(rw + 1, col).Value = shData.Range(arrCo(0) & k).Value
shGroup.Range(shGroup.Cells(rw + 3, col - 1), shGroup.Cells(rw + 3 + shData.Range(arrRn(i) & k).Cells.Count - 1, col - 1)).Value = shData.Range(arrRn(i) & k).Value
col = col + 2
Counter = Counter + 1
'reset row and col at each 5 items
If Counter = 6 Then
rw = 26
col = 3
End If
If Counter = 11 Then
rw = 52
col = 3
End If
End If
k = k + 1
Next j
shGroup.PrintPreview
Next i
Please note that the first rows that needs to be filled in each page are 4, 26 and 52, not 4, 24 and 50. In 24 and 50 you have headings that you don't want to be overwritten. (unless you have changed the format)
Well yes that has done the trick thank you so much for help.
I did try to set a counter but did not get the result I wanted. I did work out how to stop it printing blank pages thou
Most times there will only be 1 page that needs to be printed, this is the code I have so that if first page cell C3 is not blank it Prints else it moves to Next I
If shGroup.Range("C3") <> "" Then
shGroup.PrintPreview
End If
Now I did remove a line on the sheets so Row 24 and 50 are correct.
When it prints is there a way it can check if page 2 and 3 are blank or not, if not blank they print. So guess if page is blank does not print.
Once again a huge thanks for your help with this it so much appreciated.
I guess you can check the third column, rows 24 and 50:
If range("C24")="" then...you can hide the range between rows 24 and 50
If range("C50")="" then...you can hide the range between rows 50 and ... end of page
