• 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.

Code Streamlining and fixing

A

alexsheehan

Member
Hi everyone


Apologies in advance for the lengthy post, my code is quite long.


Could someone please take a look at the code below for me and firstly, see if they can fix a couple of things that aren't quite working the way i want them to, and secondly, see if the code can be streamlined in any way as although I have it working in a fashion, I'm not sure if it is the most efficient way of coding this (I'm relatively new to VBA - sorry).


Firsttly, what I am trying to achieve is copy a range from one worksheet to another (this is successful) then I am trying to set the print range automatically and printout the results restricted to the used data range and also setting the page-breaks to specified number of rows (this I can do... kind of) and this is the part I need help with. Basically i want the code below to set page-breaks every 58 rows and this is fine, however, for some reason, the first page is only 56 rows and it's throwing the rest of the pages out.


Secondly, my progress bar was working fine at one stage and now it seems to have malfunctioned, it progresses to teh first iteration bu then stops. So for example, if I have 6 pages printing, it will start off at 0%, then progress to 17% and then stop - the code still completes but there is no visual indication of this to the user.

Sub Main()

Dim Counter As Integer
Dim PctDone As Single
Dim StartRow As Integer
Dim EndRow As Integer
Dim Msg As String
Dim i As Integer
Dim PDFFileName As String
Dim MySheet As Worksheet

If StartRow > EndRow Then
Msg = "ERROR" & vbCrLf & "The starting row must be less than the ending row!"
MsgBox Msg, vbCritical, APPNAME
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("Form").Activate
StartRow = Range("StartRow")
EndRow = Range("EndRow")

If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

'===============================Clear Previous Formatting & Data
Sheets("Test").Select
Rows("32:32").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Delete

Columns("A:N").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.FormatConditions.Delete
Selection.ClearContents

With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

'===============================Copy from Range in "Form" Worksheet then Paste in "Test"
For i = StartRow To EndRow
Range("RowIndex") = i

Worksheets("Form").Range("B8:N35").Copy 'Destination:=Worksheets("Test").Range("B2")

Sheets("Test").Select

Range("B3").Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 2
Cells(NextRow, 2).Select
ActiveSheet.Paste 'Special Paste:=xlPasteValues

'===============================Copy from Range in "Form" Worksheet then Paste as Values in "Test"
Worksheets("Form").Range("B9:B9").Copy 'Destination:=Worksheets("Test").Range("B2")

Sheets("Test").Activate

ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.RowHeight = 37.5

'===============================Reset the Counter to 0 before commencing with Progress Bar
Counter = 0

Counter = Counter + 1
PctDone = Counter / ((EndRow - StartRow) + 1)

'===============================Update Progress Bar and loop through each page
With UserForm1
.FrameProgress.Caption = Format(PctDone, "0%")
.LabelProgress.Width = PctDone * .FrameProgress.Width
End With
' The DoEvents statement is responsible for the form updating
DoEvents

Next i

'===============================Unload the Progress Bar and continue with setting up the page for printing
Unload UserForm1

Range("RowIndex") = StartRow
Range("B2").Value = "=IF(valSelOption=""Q1"",""Quarter 1"",IF(valSelOption=""Q2"",""Quarter 2"",IF(valSelOption=""Q3"",""Quarter 3"",""Quarter 4"")))&"" Performance Digest ""&S12&"" - ""&"" ""&Form!J3&"" Theme"""
Range("B2").Select
Selection.RowHeight = 123

If Range("Preview") Then

Dim WorkRange As Range
Dim R As Integer, CellCount As Integer

Application.Volatile

Set WorkRange = Range(Selection, ActiveCell.SpecialCells(xlLastCell))
Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)

CellCount = WorkRange.Count

For R = CellCount To 1 Step -1
If Not IsEmpty(WorkRange(R)) Then
LASTINROW = WorkRange(R).Value
End If
Next R

'===========================Set Number of Rows Per Page for printing
Dim pages As Integer
Dim pageBegin As String
Dim PrArea As String
Dim p As Integer
Dim q As Integer
Dim nRows As Integer, nPagebreaks As Integer
Dim U As Range

Set U = ActiveSheet.UsedRange
nRows = U.Rows.Count

'===========================add pagebreak every 58 rows
If nRows > 58 Then
nPagebreaks = Int(nRows / 58)
For p = 1 To nPagebreaks
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=U.Cells(58 * p, 1)
Next p
End If

pages = ActiveSheet.HPageBreaks.Count
pageBegin = "$B$2"

For p = 1 To pages

If p > 1 Then pageBegin = ActiveSheet.HPageBreaks(p - 1).Location.Address
q = ActiveSheet.HPageBreaks(p).Location.Row - 1

'PrArea = pageBegin & ":" & "$N$" & Trim$(Str$(q))
PrArea = "$B$2:$N$" & Trim$(Str$(q))

ActiveSheet.PageSetup.PrintArea = PrArea

ActiveSheet.PageSetup.CenterFooter = Cells(q, 1)

Next p

'===========================Preview the selected pages
ActiveSheet.PrintPreview
Else

'===============================If "Preview" not selected, then continue with normal print

Application.Volatile

Set WorkRange = rngInput.Rows(1).EntireRow
Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)

CellCount = WorkRange.Count

For R = CellCount To 1 Step -1
If Not IsEmpty(WorkRange(R)) Then
LASTINROW = WorkRange(R).Value

End If
Next R

'===========================Set Number of Rows Per Page for printing

Set U = ActiveSheet.UsedRange
nRows = U.Rows.Count

'===========================add pagebreak every 58 rows

If nRows > 58 Then
nPagebreaks = Int(nRows / 58)
For p = 1 To nPagebreaks
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=U.Cells(58 * p + 1, 1)
Next p
End If

pages = ActiveSheet.HPageBreaks.Count
pageBegin = "$B$2"

For p = 1 To pages
If p > 1 Then pageBegin = ActiveSheet.HPageBreaks(p - 1).Location.Address
q = ActiveSheet.HPageBreaks(p).Location.Row - 1
PrArea = pageBegin & ":" & "$N$" & Trim$(Str$(q))

ActiveSheet.PageSetup.PrintArea = PrArea
ActiveSheet.PageSetup.CenterFooter = Cells(q, 1)

Next p
'===========================

Set MySheet = ActiveSheet
MySheet.Range("B:N").PrintOut Copies:=1, preview:=False, ActivePrinter:="Adobe PDF", printtofile:=True, Collate:=True, prtofilename:=PDFFileName
End If

Range("RowIndex") = StartRow
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Once again sorry for the long post, if the code above could be streamlined in any way that would be much appreciated.


Thanks very much in advance for any assistance.


Alex
 
Hi ,


Offhand , the first IF statement should come after the variables have been assigned their values.


If StartRow > EndRow Then

Msg = "ERROR" & vbCrLf & "The starting row must be less than the ending row!"

MsgBox Msg, vbCritical, APPNAME

End If


This statement is at a point where the variables StartRow and EndRow have just been declared , and not yet assigned any values ; by default , variables which are declared as integer will be assigned the value 0. So this IF statement really does nothing.


Putting it here would be correct if these variables were being passed as parameters to this procedure ; in this case , "main" does not have any parameters.


Move it to after the following statements :


Sheets("Form").Activate

StartRow = Range("StartRow")

EndRow = Range("EndRow")


Narayan


I am splitting up these comments , so that they are easier to read and react to.
 
Hi Alex ,


I suggest you first do manually whatever the code has to do. Clear all the page breaks in your worksheet , manually set the print range , paper size , page margins , and see in the Print Preview where the default page breaks are ; given your paper size ( which I assume is A4 ) , and your page margins , it is possible you may not be able to get 58 rows to one page.


In this case , even if you set the number of rows per page to 58 , the printer will do whatever is possible , which may be 56 rows.


Narayan
 
Hi Alex ,


It might be easier to visualize what the code is doing , if all the worksheet tabs and range names were available. If you could upload your worksheet after deleting all the data , so that all of the framework is available , it would make things simple.


As an aside , I suggest that whenever a procedure can be broken down into subroutines , it should be , since it makes testing the code and isolating any problem so much easier.


Narayan
 
Hi Alex ,


One more point is that the entire section of code for the Preview option is repeated in case previewing is not selected ( direct printing is selected ).


Can you not put the entire page formatting , page break insertion , and all other setup code outside of the IF statement ? If preview is selected , then display the pre-formatted pages on the screen , else print them out. This should reduce the code length by around 20 / 30 lines.


Narayan
 
Also, shouldn't

Counter=0

should be outside the

For i = StartRow To EndRow

Loop


and put all your Dim's at the top of the procedure
 
Thanks Narayan & Hui - points taken guys and acted upon (well, mostly) regarding the rearranging of code. Dim's now all situated nicely at the top of the code, duplicate PrintPreview code now removed and tidied up a bit, etc., etc. - here is my revised code;-

Sub Main()

Dim Counter As Integer
Dim StartRow As Integer
Dim EndRow As Integer
Dim Msg As String
Dim MySheet As Worksheet
Dim nRows As Integer, nPagebreaks As Integer
Dim PAGES As Integer
Dim pageBegin As String
Dim PctDone As Single
Dim PDFFileName As String
Dim PrArea As String
Dim WorkRange As Range
Dim i As Integer
Dim p As Integer
Dim q As Integer
Dim R As Integer, CellCount As Integer
Dim U As Range
Dim c As Integer
Dim WS As Worksheet

Sheets("Form").Activate
StartRow = Range("StartRow")
EndRow = Range("EndRow")

If StartRow > EndRow Then
Msg = "ERROR" & vbCrLf & "The starting row must be less than the ending row!"
MsgBox Msg, vbCritical, APPNAME
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

'===============================Reset the Counter to 0 before commencing with Progress Bar
Counter = 0

'===============================Clear Previous Formatting & Data
Sheets("Test").Select
Rows("32:32").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Delete

Columns("A:N").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.FormatConditions.Delete
Selection.ClearContents

With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

'===============================Copy from Range in "Form" Worksheet then Paste in "Test"
For i = StartRow To EndRow
Range("RowIndex") = i

Worksheets("Form").Range("B8:N35").Copy 'Destination:=Worksheets("Test").Range("B2")

Sheets("Test").Select

Range("B3").Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 2
Cells(NextRow, 2).Select
ActiveSheet.Paste 'Special Paste:=xlPasteValues

'===============================Copy from Range in "Form" Worksheet then Paste as Values in "Test"
Worksheets("Form").Range("B9:B9").Copy 'Destination:=Worksheets("Test").Range("B2")

Sheets("Test").Activate

ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.RowHeight = 37.5

'===============================Set progress bar value to next iteration
For c = 1 To (EndRow - StartRow)
Counter = Counter + 1
Next c

PctDone = (Counter / (EndRow - StartRow)) / (EndRow - StartRow) - (1 / (EndRow - StartRow))

'===============================Update Progress Bar Label/Caption and loop through each page
With UserForm1
.FrameProgress.Caption = Format(PctDone, "0%")
.LabelProgress.Width = PctDone * .FrameProgress.Width
End With

DoEvents

Next i

'===============================Unload the Progress Bar and continue with setting up the page for printing
Unload UserForm1

Range("RowIndex") = StartRow
Range("B2").Value = "=IF(valSelOption=""Q1"",""Quarter 1"",IF(valSelOption=""Q2"",""Quarter 2"",IF(valSelOption=""Q3"",""Quarter 3"",""Quarter 4"")))&"" Performance Digest ""&S12&"" - ""&"" ""&Form!J3&"" Theme"""
Range("B2").Select
Selection.RowHeight = 123

Application.Volatile
Set WorkRange = Range(Selection, ActiveCell.SpecialCells(xlLastCell))
Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
CellCount = WorkRange.Count
For R = CellCount To 1 Step -1
If Not IsEmpty(WorkRange(R)) Then
LASTINROW = WorkRange(R).Value

End If
Next R

'===========================Set Number of Rows Per Page for printing
Set U = ActiveSheet.UsedRange

'===========================add pagebreak every 58 rows
nRows = U.Rows.Count
If nRows > 58 Then
nPagebreaks = Int(nRows / 58)
For p = 1 To nPagebreaks
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=U.Cells(58 * p, 1)
Next p
End If

PAGES = ActiveSheet.HPageBreaks.Count
pageBegin = "$B$2"
For p = 1 To PAGES
If p > 1 Then pageBegin = ActiveSheet.HPageBreaks(p - 1).Location.Address
q = ActiveSheet.HPageBreaks(p).Location.Row - 1

PrArea = "$B$2:$N$" & Trim$(Str$(q))
ActiveSheet.PageSetup.PrintArea = PrArea

Next p

'=============================Set Page Footer
Const PAGEn As String = "&P"
Const PAGESn As String = "&N"
Const sDATE As String = "&D"
Const sTIME As String = "&T"

For Each WS In Worksheets
Worksheets("Test").Range("B2").Value
WS.PageSetup.LeftFooter = Worksheets("Test").Range("$B$2").Value
WS.PageSetup.CenterFooter = "Page " & PAGEn & " of " & PAGESn
WS.PageSetup.RightFooter = "Printed on " & sDATE & " by " & Worksheets("Test").Range("$O$1").Value & " at " & sTIME
Next WS

'===========================If "Preview" is selected, then Preview the selected pages - don't print
If Range("Preview") Then

ActiveSheet.PrintPreview

Else

'===========================Else print the selected pages to PDF

Set MySheet = ActiveSheet
MySheet.Range("B:N").PrintOut Copies:=1, preview:=False, ActivePrinter:="Adobe PDF", printtofile:=True, Collate:=True, prtofilename:=PDFFileName

End If

Range("RowIndex") = StartRow
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

However, in terms of subroutines - are you able to suggest how I split this up into subroutines? (best fit?) as I wouldn't know where to start.


I have now managed to get my progress bar to update again so i no longer need help with this, however I still need assistance with the page-breaks and, in answer to your question Narayan, yes I have have tried manually clearing the print range, inputting the page breaks manually and everything prints perfectly, it is just the code I have does not seem to function correctly. Maybe I have used the wrong syntax or have not selected the correct ranges or something?


Obviously if you think my code can be improved further, please feel free to suggest. Please don't think I'm being lazy, I am still learning VBA and I just need to have some assistance in getting code functioning better and working more efficiently.


Cheers for all your help folks.


Alex
 
Hi Alex ,


I am finding it difficult to understand what the code is doing ; can you post here what you expect it to do ? What is the copying supposed to do ? What is LASTINROW doing ?


This is not a criticism of the code ; I find that code that I write is always easier for me to understand than someone else's code ! Even though my own code may be more inefficient. Of course , the same may be applicable to others !


Narayan
 
Technically you also don't need the first occurrence of the following line


If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub


as you activate a specific sheet just before you check
 
You must log in or register to reply here.
Back
Top