'Use to render the error messages from error handler.
Function ErrorMessage( _
pErrNum As Integer, _
psErrDescr, _
Optional psSubName = "", _
Optional psStepID = "")
' If pErrNum = 18 Then Exit Function
Dim sMsg As String
Dim sTitle As String
sTitle = "Error Message"
sMsg = "Error #" & pErrNum & " occurred"
If psSubName <> "" _
Then sMsg = sMsg & Chr(10) & "in procedure " & psSubName
sMsg = sMsg & "."
If psStepID <> "" _
Then sMsg = sMsg & Chr(10) & "Step ID: " & psStepID & "."
sMsg = sMsg & Chr(10) & "Error Type: " & psErrDescr & "."
MsgBox sMsg, vbOKOnly + vbCritical, sTitle
Err.Clear
Application.StatusBar = False
DoEvents
End Function
'
' ----------------------------------------------------------------
' Procedure Name: GetFileName
' Purpose: Allow user to point to a file (name).
' Procedure Kind: Function
' Procedure Access: Public
' Parameter psPathAndFile (String): The path and file are returned to caller in this ByRef parameter.
' Parameter psStartPath (String): The start path.
' Parameter psFilterName (String): The file-to-select name filter.
' Parameter psFilter (String): The file-to-select file name extension filter.
' Parameter psTitle (String): Title for the dialog box.
' Author: Jim
' Date: 8/24/2023
' ----------------------------------------------------------------
Function GetFileName( _
ByRef psPathAndFile As String, _
ByVal psStartPath As String, _
Optional ByVal psFilterName As String = "Any file", _
Optional ByVal psFilter As String = "*.xl*?", _
Optional ByVal psTitle As String = "Select a file.")
Dim fdGetFileName As Office.FileDialog
Dim vAns As Variant
Set fdGetFileName = Application.FileDialog(msoFileDialogFilePicker)
DoGetFile:
With fdGetFileName
.Filters.Clear
.Filters.Add psFilterName, psFilter, 1
.Title = psTitle
.AllowMultiSelect = False
.InitialFileName = psStartPath
If .Show = True Then
psPathAndFile = .SelectedItems(1)
Exit Function
Else
vAns = MsgBox("Please select a file.", vbOKCancel + vbQuestion, "Selecting a folder containing PDFs to Print")
If vAns = vbOK Then GoTo DoGetFile
End If
End With
End Function
' ----------------------------------------------------------------
' Procedure Name: GetFormulasRowsData
' Purpose: Count menu item rows for each station.
' Procedure Kind: Function
' Procedure Access: Public
' ByRef Parameter paiNumberRows (Long): Array holding first row and row count for each station.
' Return Type: Long)
' Author: Jim
' Date: 8/5/2023
' ----------------------------------------------------------------
Function GetFormulasRowsData(ByRef pavAnchorRows() As Variant)
'
Dim iLastRow As Long
Dim iRow As Long
Dim iStationsCount As Long
Dim iStation As Long
ReDim pavAnchorRows(1 To 2, 1)
With Worksheets("Formulas")
iLastRow = .Range("B1").Cells(Rows.Count, 1).End(xlUp).Row
For iRow = 1 To iLastRow
If .Range("B1").Cells(iRow).value = "Recipe #" _
Then
iStationsCount = iStationsCount + 1
ReDim Preserve pavAnchorRows(1 To 2, iStationsCount)
' Save station anchor row value to the array.
pavAnchorRows(1, iStationsCount) = iRow
End If
Next iRow
' Get row counts. Put them into the array.
For iStation = 1 To UBound(pavAnchorRows, 2)
iRow = 0
With .Range("A1").Cells(pavAnchorRows(1, iStation))
Do
iRow = iRow + 1
Loop Until Trim(.Offset(iRow)) = ""
' Save station rows count to the array.
pavAnchorRows(2, iStation) = iRow - 1
End With
Next iStation
End With 'Worksheets("Report")
End Function
' ----------------------------------------------------------------
' Procedure Name: GetReportStationsData
' Purpose: Count menu item rows for each station.
' Procedure Kind: Function
' Procedure Access: Public
' ByRef Parameter pavNumberRows (Long): Array holding first row and row count for each station.
' Return Type: Long)
' Author: Jim
' Date: 8/5/2023
' ----------------------------------------------------------------
Function GetReportStationsData(ByRef pavNumberRows() As Variant, Optional ByVal iColOffset As Long = 0)
'
Dim iLastRow As Long
Dim iRow As Long
Dim iStation As Long
ReDim pavNumberRows(1 To 3, 1)
With Worksheets("Report")
iLastRow = .Range("A1").Cells(Rows.Count, 1).End(xlUp).Row
For iRow = 1 To iLastRow
If .Range("A1").Offset(0, iColOffset).Cells(iRow).value = "Recipe #" _
Then
iStation = iStation + 1
ReDim Preserve pavNumberRows(1 To 3, iStation)
' Save station anchor cell row to the array
pavNumberRows(1, iStation) = iRow + 1
End If
Next iRow
' Get row counts and station names. Put them into the array.
For iStation = 1 To UBound(pavNumberRows, 2)
iRow = 0
With .Range("A1").Cells(pavNumberRows(1, iStation))
Do
iRow = iRow + 1
Loop Until Trim(.Offset(iRow)) = ""
' Save station rows count to array.
pavNumberRows(2, iStation) = iRow
' Save station name to array.
pavNumberRows(3, iStation) = .Offset(-2, 1).value
End With
Next iStation
End With 'Worksheets("Report")
End Function
' ----------------------------------------------------------------
' Procedure Name: GetStationNames
' Purpose: Get list of stations as a comma separated string. Used
' to get the list of stations for the Formulas top (picture).
' Procedure Kind: Function
' Procedure Access: Public
' Author: Jim
' Date: 8/30/2023
' ----------------------------------------------------------------
Function GetStationNames()
Dim sStationsNamesList As String
Dim sStationName As String
Dim iStationsCount As Long
Dim iStation As Long
iStationsCount = 9
GetStationNames = "none"
For iStation = 1 To iStationsCount
sStationName = [Formulas].Range("Station" & iStation & "Name")
If UCase(sStationName) <> "NOT USED" And sStationName <> "" _
Then
If sStationsNamesList <> "" And iStation < iStationsCount _
Then sStationsNamesList = sStationsNamesList & ", "
sStationsNamesList = sStationsNamesList & Application.WorksheetFunction.Proper(sStationName)
End If
Next
GetStationNames = sStationsNamesList
End Function
' ----------------------------------------------------------------
' Procedure Name: CreateFormulasTop
' Purpose: Create the picture for the top of the formulas worksheet (report).
' Procedure Kind: Sub
' Procedure Access: Public
' Author: Jim
' Date: 8/31/2023
' ----------------------------------------------------------------
Sub CreateFormulasTop()
Dim pPicTop As Picture
Dim sPictureName As String
sPictureName = "FormulasTop"
' ----------------------
' Error Handling
' ----------------------
Dim sSubName As String
Dim sStepID As String
sSubName = "CreateFormulasTop"
sStepID = ""
On Error GoTo ErrHandler
' ----------------------
On Error Resume Next
Worksheets("Formulas").Shapes(sPictureName).Delete
On Error GoTo ErrHandler
sStepID = "copying Formulas worksheet top as picture"
' Copy the range that will become the picture.
' Paste the "temporary version" of picture.
With Worksheets("Form Top")
.Range("FormulasTop").Copy
Set pPicTop = .Pictures.Paste
End With
sStepID = "formatting Formulas worksheet top picture"
' Format the picture to be filled with white so it is opaque.
With pPicTop.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
sStepID = "putting form picture into Formulas worksheet"
' Cut the picture to prepare for the paste to the formulas worksheet.
pPicTop.Cut
' Copy the picture to the Formulas worksheet.
With Worksheets("Formulas")
.Activate
.Range("A1").Activate
Set pPicTop = .Pictures.Paste
pPicTop.Name = sPictureName
.Range("B19").Activate
End With
' Nudge the picture to the right.
pPicTop.ShapeRange.IncrementLeft 3.3333070866
Application.CutCopyMode = False
Exit Sub
ErrHandler:
Call ErrorMessage(Err.Number, Err.Description, sSubName, sStepID)
End Sub
' ----------------------------------------------------------------
' Procedure Name: ImportReportWorksheet
' Purpose: Allow user to point to then open the new Report file.
' Procedure Kind: Sub
' Procedure Access: Public
' Author: Jim
' Date: 8/10/2023
' ----------------------------------------------------------------
Sub ImportReportWorksheet()
Dim wsReportNew As Worksheet
Dim sPathAndFile As String
Dim sStartPath As String
Dim rCell As Range
' ----------------------
' Error Handling
' ----------------------
Dim sSubName As String
Dim sStepID As String
sSubName = "ImportReportWorksheet"
sStepID = ""
On Error GoTo ErrHandler
' ----------------------
' Error Messaging
sStepID = "1. setting path to the Report"
'sStartPath = "C:\Users\" & Environ("Username") & "\Desktop"
sStartPath = ThisWorkbook.Path
Application.DisplayAlerts = False
sStepID = "2. deleting existing Report worksheet"
On Error Resume Next
ThisWorkbook.Worksheets("Report").Delete
On Error GoTo ErrHandler
' Error Messaging
sStepID = "3. getting path and file for Report"
' Let user point to the report file to open.
Call GetFileName(sPathAndFile, sStartPath, "Report File", "*.xl*")
' Error Messaging
sStepID = "4. opening and accessing Report workbook"
' Get/open the report folder
Workbooks.Open sPathAndFile
' Point worksheet object at the Report worksheet in the workbook
' opened just above and which becomes the active workbook.
Set wsReportNew = ActiveWorkbook.Worksheets(1)
' Error Messaging
sStepID = "5. checking that worksheet is a Report"
' Check that it is a Report worksheet which was imported. Do so by
' looking for the string "Report Parameters" in the raw report.
With wsReportNew
Set rCell = .Cells.Find(What:="Report Parameters", _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)
If rCell Is Nothing _
Then
MsgBox "The worksheet imported is not a Report", vbCritical
ActiveWorkbook.Close
Exit Sub
End If
End With
' Error Messaging
sStepID = "6. importing Report worksheet"
' Put the raw report into the
wsReportNew.Move Before:=ThisWorkbook.Sheets(1)
' Error Messaging
sStepID = "7. naming and formatting Report worksheet"
' Rename the just imported raw version of the report.
ActiveSheet.Name = "Report"
' Do reformatting of the report.
Call ReformatReport
Exit Sub
ErrHandler:
Call ErrorMessage(Err.Number, Err.Description, sSubName, sStepID)
End Sub
' ----------------------------------------------------------------
' Procedure Name: ReformatReport
' Purpose: Reformat and remove merged cells from the stations groups ranges.
' Procedure Kind: Sub
' Procedure Access: Public
' Author: Jim
' Date: 7/20/2023
' ----------------------------------------------------------------
Sub ReformatReport()
' Worksheet object for the worksheet named original
Dim wsReport As Worksheet
Dim wsLoop As Worksheet
Dim bReportSheetExists As Boolean
Dim sReportSheetName As String
' Used when looping through data a station's data.
Dim iRow As Long
' Used when looping through stations.
Dim iStation As Long
' Used to get count of rows for each station.
Dim avNumberRows() As Variant
' Used to locate the last row in stations' data range.
Dim iLastRow As Long
' Used as a flag to tell code whether the workshet has already been reformatted.
Dim vIsReportFormatted As Variant
Dim sPageHeaderText As String
Dim sRunLabel1 As String
Dim sRunLabel2 As String
Dim sRunLabel3 As String
' ----------------------
' Error Handling
' ----------------------
Dim sSubName As String
Dim sStepID As String
sSubName = "ReformatReport"
sStepID = ""
On Error GoTo ErrHandler
' ----------------------
Application.DisplayAlerts = False
' --------------------------------------------
' The Report Worksheet Must Exist
' --------------------------------------------
' Error Messaging
sStepID = "1. checking Report worksheet exists"
sReportSheetName = "Report"
bReportSheetExists = False
For Each wsLoop In ThisWorkbook.Worksheets
If wsLoop.Name = sReportSheetName _
Then
bReportSheetExists = True
Exit For
End If
Next wsLoop
If Not bReportSheetExists _
Then
MsgBox "The worksheet named " & sReportSheetName & " was not found.", vbExclamation
Exit Sub
End If
' --------------------------------------------
' Initializations
' --------------------------------------------
' Error Messaging
sStepID = "2. initializations"
' Point worksheet object to the worksheet named Report.
Set wsReport = ThisWorkbook.Worksheets(sReportSheetName)
' Get/set the last row in the data.
iLastRow = wsReport.Range("A1").Cells(Rows.Count, 1).End(xlUp).Row
vIsReportFormatted = False
On Error Resume Next
vIsReportFormatted = wsReport.Names("HasBeenFormatted").Index <> (Err.Number = 0)
On Error GoTo ErrHandler
' Do not reformat the worksheet if it has already been processed.
If vIsReportFormatted _
Then
MsgBox "The data has already been formatted.", vbInformation
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Error Messaging
sStepID = "3. checking Report worksheet exists"
' Turn off gridlines (visible).
ActiveWindow.DisplayGridlines = False
With wsReport
sPageHeaderText = .Range("H1")
sRunLabel1 = .Range("Z1")
sRunLabel2 = .Range("Z2")
sRunLabel3 = .Range("Z3")
End With
' -----------------------------------------------------
' Remove Borders and cell Fill Color
' -----------------------------------------------------
' Error Messaging
sStepID = "4. removing cell borders and fill color"
' Remove cell borders at the top of the worksheet.
With wsReport.Range("A1:AK20")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
' Remove blue at top of the Report worksheet.
With wsReport.Rows("4:4").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' -----------------------------------------------------
' Move column D values -- if any -- to Column C
' -----------------------------------------------------
' Some Recipe Names are located in column D. All should be in
' column C so move those values in column D to column C.
With wsReport.Range("D1")
For iRow = 1 To iLastRow
If .Cells(iRow) <> "" Then .Cells(iRow).Offset(0, -1).value = .Cells(iRow).value
.Cells(iRow) = ""
Next iRow
End With
' ----------------------------------------------
' Remove Extra Columns, Align Remaining
' ----------------------------------------------
' Error Messaging
sStepID = "5. removing extra columns, aligning remaining"
' Delete the extra columns in data groups' range. That has the
' effect of unmerging the cells for the respective data item.
' Also, format the alignment of the remaining cells. Note,
' statrt with leftmost columns and when processing delete columns
' from right to left.
With wsReport
.Columns("AK:AK").Delete Shift:=xlToLeft
.Columns("AJ:AJ").Delete Shift:=xlToLeft
With .Columns("AI:AI")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("AH:AH").Delete Shift:=xlToLeft
.Columns("AG:AG").Delete Shift:=xlToLeft
With .Columns("AF:AF")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("AE:AE").Delete Shift:=xlToLeft
.Columns("AD:AD").Delete Shift:=xlToLeft
.Columns("AC:AC").Delete Shift:=xlToLeft
With .Columns("AB:AB")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("AA:AA").Delete Shift:=xlToLeft
.Columns("Z:Z").Delete Shift:=xlToLeft
With .Columns("Y:Y")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("X:X").Delete Shift:=xlToLeft
With .Columns("W:W")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("V:V").Delete Shift:=xlToLeft
.Columns("U:U").Delete Shift:=xlToLeft
With .Columns("T:T")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("S:S").Delete Shift:=xlToLeft
With .Columns("R:R")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("Q:Q").Delete Shift:=xlToLeft
.Columns("P:P").Delete Shift:=xlToLeft
With .Columns("O:O")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("N:N").Delete Shift:=xlToLeft
With .Columns("M:M")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("L:L").Delete Shift:=xlToLeft
.Columns("K:K").Delete Shift:=xlToLeft
With .Columns("J:J")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("I:I").Delete Shift:=xlToLeft
.Columns("H:H").Delete Shift:=xlToLeft
With .Columns("G:G")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("F:F").Delete Shift:=xlToLeft
.Columns("E:E").Delete Shift:=xlToLeft
.Columns("D:D").Delete Shift:=xlToLeft
With .Columns("C:C")
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlBottom
End With
.Columns("B:B").Delete Shift:=xlToLeft
End With
' ------------------------------
' Various Columns' Width
' ------------------------------
' Error Messaging
sStepID = "6. setting columns' width"
With wsReport
.Columns("A:A").EntireColumn.ColumnWidth = 8.5 'Recipe #
.Columns("B:B").EntireColumn.ColumnWidth = 18 'Recipe name
.Columns("C:C").EntireColumn.ColumnWidth = 10 'Portion Size
.Columns("D:D").EntireColumn.ColumnWidth = 15.43 'Utensils
.Columns("E:E").EntireColumn.ColumnWidth = 7.5 'HACCP
.Columns("F:F").EntireColumn.ColumnWidth = 9.14 'Prep Svgs Total
.Columns("G:G").EntireColumn.ColumnWidth = 7.9 'Leftover
.Columns("H:H").EntireColumn.ColumnWidth = 8.71 'Serve Svgs Total
.Columns("I:I").EntireColumn.ColumnWidth = 8.71 'Serve Svgs ALC
.Columns("J:J").EntireColumn.ColumnWidth = 8.71 'Serve Svgs Reimb
.Columns("K:K").EntireColumn.ColumnWidth = 8.57 'After Cook Temp
.Columns("L:L").EntireColumn.ColumnWidth = 8.64 'Temp 1
.Columns("M:M").EntireColumn.ColumnWidth = 8.64 'Temp 2
End With
' ----------------------------
' Remove Rows' Merging
' ----------------------------
' Error Messaging
sStepID = "7. removing rows' merging"
' Some rows will have merged cells -- dates and location. Unmerge those cells.
wsReport.Rows.AutoFit
With wsReport.Range("A1")
For iRow = 1 To iLastRow
With .Cells(iRow)
.MergeCells = False
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
If .value = "Recipe #" _
Then
.HorizontalAlignment = xlCenter
.RowHeight = 24
End If
End With
Next iRow
End With
' ----------------------------
' Cells Format xlTop
' ----------------------------
' Error Messaging
sStepID = "8. setting cells' vertical alignment"
' Format all data cells to have vertical alignment of top.
With wsReport.Range("A1")
For iRow = 1 To iLastRow
If .Cells(iRow).value Like "##*" _
Then
.Cells(iRow).EntireRow.VerticalAlignment = xlTop
End If
Next iRow
End With
' ---------------------------------------
' Format Page (i.e., "Layout")
' ---------------------------------------
' Error Messaging
sStepID = "9. doing page layout"
' Format the page so it is printable.
With wsReport
' Set page margins.
With .PageSetup
.Orientation = xlLandscape
.Zoom = 90
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.CenterHorizontally = True
.CenterVertically = True
End With
' Set row height for rows between data groups.
With .Range("A21")
For iRow = 1 To iLastRow
If Trim(.Cells(iRow).value) = "" _
Then .Cells(iRow).RowHeight = 3
Next
.Cells(iLastRow + 1).RowHeight = 3
End With
' Format borders for the leftmost column in the data groups.
.Columns("L:L").Copy
.Columns("M:M").PasteSpecial Paste:=xlPasteFormats
With .Columns("N:N")
.PasteSpecial Paste:=xlPasteFormats
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.ColumnWidth = 0.33
End With
' -----------------------------------------------
' Manage Range at Bottom of Page
' -----------------------------------------------
' Error Messaging
sStepID = "10. formatting page bottom"
With .Range("A109:M109")
.RowHeight = 25
.MergeCells = True
.WrapText = True
.VerticalAlignment = xlTop
End With
With .Range("A114:M114")
.RowHeight = 25
.MergeCells = True
.WrapText = True
.VerticalAlignment = xlTop
End With
End With 'wsReport
' -----------------------------------------------
' Manage Range at Top of Page
' -----------------------------------------------
' Error Messaging
sStepID = "11. formatting page top"
With wsReport
.Activate
.Range("A4:A19").EntireRow.Delete Shift:=xlUp
.Range("B3").Activate
.Range("C1").value = sPageHeaderText
With .Range("C1:K1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlTop
.WrapText = False
.MergeCells = False
With .Font
.Name = "sans-serif"
.Size = 12
.Bold = True
End With
End With
.Range("M2").value = sRunLabel1
.Range("M3").value = sRunLabel2
.Range("M4").value = sRunLabel3
With .Range("M2:M4")
.HorizontalAlignment = xlRight
.WrapText = False
End With
End With 'wsReport
Application.CutCopyMode = False
' -----------------------------------------------
' Add numbers to Station's Menu Items
' -----------------------------------------------
' Error Messaging
sStepID = "12. adding line item numbers"
Call GetReportStationsData(avNumberRows())
With wsReport
' Insert column A for row numbers.
.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Column A width
.Columns("A:A").ColumnWidth = 2.43
' Get row counts. Put them into the station's menu items' rows.
For iStation = 1 To UBound(avNumberRows, 2)
With .Range("A1").Cells(avNumberRows(1, iStation))
For iRow = 1 To avNumberRows(2, iStation)
.Offset(iRow - 1) = iRow
.VerticalAlignment = xlTop
Next iRow
End With
Next iStation
End With 'Worksheets("Report")
' -------------------------------------------------------
' Remove remaining merged cells in Report data
' -------------------------------------------------------
sStepID = "13. removing remaining merged cells"
With wsReport.Range("B1")
For iRow = 1 To iLastRow
With .Cells(iRow)
.MergeCells = False
.WrapText = False
End With
Next iRow
End With
' ---------------------------------------------------
' Add Report worksheet scoped Name as Flag
' ---------------------------------------------------
' So code knows whether a report worksheet has already been
' reformatted add a name to the worksheet as a flag.
sStepID = "14. adding has been processed name"
wsReport.Names.Add Name:="HasBeenFormatted", RefersTo:="=TRUE"
' Error Messaging
sStepID = "15. closing out"
Worksheets("Formulas").Activate
Application.EnableEvents = True
Closeout:
Exit Sub
ErrHandler:
Call ErrorMessage(Err.Number, Err.Description, sSubName, sStepID)
End Sub
' ----------------------------------------------------------------
' Procedure Name: StationDataToFormulasSheet
' Purpose: Copy station/menu data from Report worksheet to Formulas worksheet.
' Procedure Kind: Sub
' Procedure Access: Public
' Author: Jim
' Date: 8/8/2023
' ----------------------------------------------------------------
Sub StationDataToFormulasSheet()
' Array holding data about stations in the Report.
Dim avReportRanges() As Variant
' Array holding data about anchor cells in the Formulas.
Dim avFormulasAnchorsRows() As Variant
' The worksheet named Formulas.
Dim wsFormulas As Worksheet
' The worksheet named Report.
Dim wsReport As Worksheet
' Used for iterating through stations in Report worksheet.
Dim iStation As Long
' Count of stations in the Report worksheet.
Dim iReportStationsCount As Long
' Count of stations in the Report worksheet.
Dim iFormulasStationsCount As Long
' Rows count for the station being processed.
Dim iStationRowsCount As Long
' Holds the name of the station being processed.
Dim sStationName As String
' Count of (unused) rows to hide for a station in the Formulas worksheet.
Dim iHideRowsCount As Long
' Range where the station-specific anchor cell is located in Formulas worksheet.
Dim rFormulasStationAnchor As Range
' Range where the station-specific anchor cell is located in Report worksheet.
Dim rReportStationAnchor As Range
' Count of data columns to transfer from Report to Formulas for each station.
Dim iDataColumnsCount As Long
' Count of ALL rows of data in all stations in Formulas worksheet.
' ALL meaning includes hidden rows, if any.
Dim iAllStationRowsCount As Long
' ----------------------
' Error Handling
' ----------------------
Dim sSubName As String
Dim sStepID As String
sSubName = "StationDataToFormulasSheet"
sStepID = ""
On Error GoTo ErrHandler
' ----------------------
' How many columns of data to copy from Report to Formulas worksheet.
iDataColumnsCount = 5
' Set count of ALL rows of data in all stations in Formulas worksheet.
iAllStationRowsCount = 20
' Error Messaging
sStepID = "setting worksheet Report and Formulas objects"
Set wsFormulas = [Formulas]
Set wsReport = Worksheets("Report")
' Error Messaging
sStepID = "1. getting Report and Formulas worksheet rows' data"
' Fill array that contains the row numbers of and rows count for stations'
' data in the Report worksheet. The second parameter is the column offset
' (from a row's index column).
Call GetReportStationsData(avReportRanges(), 1)
' Fill array that contains the anchor cell's row numbers of and rows count
' for stations' data in Formulas worksheet
Call GetFormulasRowsData(avFormulasAnchorsRows())
' Get count of stations in 1. the Report worksheet, 2. the Formulas worksheet.
iReportStationsCount = UBound(avReportRanges, 2)
iFormulasStationsCount = UBound(avFormulasAnchorsRows, 2)
' Error Messaging
sStepID = "2. processing Formulas worksheet data"
For iStation = 1 To iReportStationsCount
With wsFormulas
' Unhide the station data rows in Formulas worksheet for the station being processed.
.Range("Station" & iStation & "Rows").EntireRow.Hidden = False
' Set/get anchor cell in formulas worksheet for the respective station.
Set rFormulasStationAnchor = .Range("B1").Offset(avFormulasAnchorsRows(1, iStation))
' Put the station name two cells above the station anchor cell
' (i.e., range rFormulasStationAnchor).
rFormulasStationAnchor.Offset(-2).value = avReportRanges(3, iStation)
' Hide all rows for the station in formulas worksheet.
With rFormulasStationAnchor
' Hide all rows for a station in Formulas worksheet.
.Resize(avFormulasAnchorsRows(2, iStation)).EntireRow.Hidden = True
' Clear all values for the respective statio in the formulas worksheet.
.Resize(avFormulasAnchorsRows(2, iStation), iDataColumnsCount).value = ""
End With
' Unhide rows needed in formulas worksheet for the respective station
' in the report worksheet.
With rFormulasStationAnchor
.Resize(avReportRanges(2, iStation)).EntireRow.Hidden = False
.Resize(avReportRanges(2, iStation)).EntireRow.AutoFit
End With
End With
' Error Messaging
sStepID = "3. processing Report worksheet data"
With wsReport
' DATA anchor cell for the station being copied from in Report worksheet.
Set rReportStationAnchor = .Range("B1").Cells(avReportRanges(1, iStation))
' Copy data from Report worksheet and paste to Formulas worksheet.
With rReportStationAnchor.Resize(avReportRanges(2, iStation), iDataColumnsCount)
.Copy rFormulasStationAnchor
End With
rReportStationAnchor.Resize(avReportRanges(2, iStation)).EntireRow.AutoFit
End With
Next iStation
' Error Messaging
sStepID = "4. hiding unused Formulas station(s)"
' Hide any unused stations in the Formulas worksheet.
If iReportStationsCount < iFormulasStationsCount _
Then
For iStation = iReportStationsCount + 1 To iFormulasStationsCount
[Formulas].Range("Station" & iStation & "Rows").EntireRow.Hidden = True
Next iStation
End If
' Error Messaging
sStepID = "5. formatting formula's cells' inner/vertical and right borders"
With wsFormulas
For iStation = 1 To iReportStationsCount
' Set/get anchor cell in formulas worksheet for the respective station.
Set rFormulasStationAnchor = .Range("B1").Offset(avFormulasAnchorsRows(1, iStation))
With rFormulasStationAnchor.Resize(iAllStationRowsCount, iDataColumnsCount)
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
End With
Next iStation
End With 'wsFormulas
Application.Calculate
Exit Sub
ErrHandler:
Call ErrorMessage(Err.Number, Err.Description, sSubName, sStepID)
End Sub
