Public frmProg As ufxl_ProgressIndicator
Public Sub Main_UsingPI()
Set frmProg = New ufxl_ProgressIndicator
Load frmProg
With frmProg
.Caption = "Transfer Reservations"
.Add "Copying", "copy"
.Add "Second Process"
.Add "Formatting", "format"
.Add "Print Setup + Add Formulae", "last"
' .ShowSubProcess = False
.EstimateTimes = True
.ProgramName = "Main"
.ColorTotalBar = RGB(96, 0, 128)
.Show
End With
End Sub
Private Sub Main()
' Compare 2005 and 2006 and transfers all people who have
' not reserved in 2006 and put them on a separate sheet.
'// Since this name appears in a couple of places down in the code
'// easier maintenance if put up top as a constant. Then if ever want
'// to change, don't have to do a FIND/REPLACE thing -- just change
'// up top and all done.
Const c_strNotResdName As String = "Not Reserved"
Dim lRow As Long
Dim R As Range, rData As Range
Dim sCur As String
Dim WS1 As Worksheet, WS2 As Worksheet
Dim wsNotReserved As Worksheet, ws As Worksheet
Dim LastRow As Long, lngSrcRowCnt As Long
Dim p!
Application.ScreenUpdating = False
Set WS1 = Sheets("2005")
Set WS2 = Sheets("2006")
Set rData = WS2.Range("C2:C" & WS2.Cells(Rows.Count, "C").End(xlUp).Row)
' Check whether macro has already produced the
' Not Reserved sheet and delete it.
On Error Resume Next 'if error occurs, continue to next line of code
'attempt to set ws variable
Set wsNotReserved = Sheets(c_strNotResdName)
'if sheet already exists, no error will occur
If Err = 0 Then 'if sheet exists
wsNotReserved.Cells.Clear
'// ¿¿¿ only need to do this to WS2 if wsNotReserved existed??? //
With WS2
'only selecting sheet to remove freeze panes
.Select
ActiveWindow.FreezePanes = False
.Cells.EntireColumn.Hidden = False
.AutoFilterMode = False
.Columns("T:AE").Delete
.Rows("1:1").Delete
End With
Else
Set wsNotReserved = Sheets.Add(After:=Sheets(3))
wsNotReserved.Name = c_strNotResdName
End If
On Error GoTo 0 'reset error trapping
'since the Not Reserved ws is being deleted and/or added as a new *blank* sheet
'every time, this statement will always result in lRow being set as 1
'You can just hard-code this value as 1 to save a tiny bit of time
lRow = 1
'lRow = wsNotReserved.Cells(Rows.Count, "C").End(xlUp).Row
' **** SUBPROCCESS OF COMPARING SHEETS AND PLACING ON
' A NEW SHEET. I WOULD LIKE TO TRACK THIS IN IT'S OWN
' PROGRESS BAR.
lngSrcRowCnt = WS1.Cells(Rows.Count, "C").End(xlUp).Row
For Each R In WS1.Range("C2:C" & lngSrcRowCnt)
sCur = R.Text
If Application.CountIf(rData, sCur) = 0 Then
lRow = lRow + 1
wsNotReserved.Rows(lRow).Value = WS1.Rows(R.Row).Value
End If
frmProg.UpdateProgressMajor R.Row / lngSrcRowCnt, "copy"
Next R
' **** END OF SUBPROCESS
'can loop so sheets/ranges do not have to be selected
p! = 0!
For Each ws In Sheets(Array(WS2.Name, wsNotReserved.Name))
With ws
.Columns("T:AE").Insert Shift:=xlToRight
'enter the first value in T1
.Range("T1") = "10"
frmProg.UpdateProgressMinor 0.2
'use Fill Series to enter numbers in the rest of the range
.Range("T1:V1").DataSeries Rowcol:=xlRows, Type:=xlLinear, Step:=1
frmProg.UpdateProgressMinor 0.6
'enter the first value in W1
.Range("W1") = "1"
'use Fill Series to enter numbers in the rest of the range
.Range("W1:AE1").DataSeries Rowcol:=xlRows, Type:=xlLinear, Step:=1
frmProg.UpdateProgressMinor 1
End With
p! = p! + 0.5!
frmProg.UpdateProgressMajor p!, 2
Next ws
With WS2
'copy row 1 on 2006 ws and paste to row 1 on Not Reserved ws
.Rows("1:1").Copy Destination:=wsNotReserved.Rows("1:1")
End With
' Sort and Fit Sheets
'you are doing the same thing (other than the sort) for all 3 sheets--can use a loop
p = 0!
For Each ws In Sheets(Array(WS1.Name, WS2.Name, wsNotReserved.Name))
With ws
'only selecting the sheet/range so freeze panes can be activated
.Select
.Range("D2").Select
ActiveWindow.FreezePanes = True
With .Columns("H:H")
.NumberFormat = "[<=9999999]###-####;(###) ###-####"
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.MergeCells = False
End With
.Cells.EntireColumn.AutoFit
Select Case .Name 'check the name of the worksheet is being checked
Case Is = WS1.Name 'if the current sheet name is 2005
'perform this sort
.Cells.Sort Key1:=.Range("C2"), Order1:=xlAscending, Key2:=.Range("T2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
.Range("C1").Select
Case Else 'if current sheet is 2006 or Not Reserved
'perform this sort
.Cells.Sort Key1:=.Range("C2"), Order1:=xlAscending, Key2:=.Range("AF2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom
End Select
End With
p! = p! + 1!
frmProg.UpdateProgressMajor p! / 3!, "format"
Next ws
'again, you are doing the same thing (other than the sort) for multiple sheets--can use a loop
p = 0
For Each ws In Sheets(Array(WS2.Name, wsNotReserved.Name))
With ws
.Range("A:B,G:G,I:I,K:L,N:N,P:Q,AG:AK,AM:AN,AQ:AT,AV:AW").EntireColumn.Hidden = True
.Columns("F:F").ColumnWidth = 3.33
.Columns("H:H").ColumnWidth = 14.44
.Columns("AF:AF").ColumnWidth = 4.89
.Columns("AX:AX").ColumnWidth = 80
.Cells.RowHeight = 26
.Range("AX1") = "Comment"
frmProg.UpdateProgressMinor 0.15
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
With .Range("$A$2:$AX" & LastRow)
'add border around the outside of the range in one go
.BorderAround
'add borders inside the range
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
.AutoFilterMode = False
frmProg.UpdateProgressMinor 0.3
.Rows("1:1").Insert Shift:=xlDown
.Range("C1").FormulaR1C1 = "=R[2]C[41]&"" Extracted ""&(TEXT(R[2]C[13],""mm/dd/yy""))"
' Set up page and print area
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
With .PageSetup
.PrintArea = "$A$1:$AX" & LastRow
.PrintTitleRows = "$1:$2"
.PrintTitleColumns = "$C:$C"
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
'.PrintQuality = 600 'Taken out do to User Excel Version Conflicts
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLegal
.FirstPageNumber = xlAutomatic
.Order = xlOverThenDown
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 2
.FitToPagesTall = False
End With
frmProg.UpdateProgressMinor 0.5
'Count Days
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
.Range("T3").FormulaR1C1 = "=SUMPRODUCT(--(MONTH(ROW(INDIRECT(RC18&"":""&(RC19-1))))=R2C))"
.Range("T3").AutoFill Destination:=.Range("T3:AE3"), Type:=xlFillDefault
.Range("T3:AE3").AutoFill Destination:=.Range("T3:AE" & LastRow), Type:=xlFillDefault
.Range("T3:AE" & LastRow).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
Application.Goto .Range("C1")
End With
p = p + 0.5
frmProg.UpdateProgressMajor p, "last"
Next ws
Application.ScreenUpdating = True
End Sub
).
Worst case, ya can't use it. Best case, ya can use it and you might learn something (er - maybe; no guarantees - 
).
