Some of the MACROS in this list: $$$$$ Eaton macro - Labor Utilization $$$ $$$$$ Rename Aiptek camera files Code $$$ $$$$$ Qcom Macros Code $$$ $$$$$ Qcom TablesMacro Code $$$ $$$$$ Shannon’s Macro Code (1st Eaton) $$$ $$$$$ Microsoft Word Macros $$$ $$$$$ Vocab Quiz Code $$$ $$$$$ Eaton macro - Labor Utilization $$$ May 20, 2006 ' Variable Declarations Public GetDataArray(22, 1) As String Private DataFileName As String Private EmployeeLastName As String Private ErrorFlag As String Private ErrorFlag2 As Variant Private ErrorFlag3 As Variant Private FilesLocation As String Private FilesLocationAndDataFileName As String Private FilesLocationAndReportName As String Private MonthOfTheYear As Integer Private ReportName As String Private TempAddress1 As String Private TempAddress2 As String Private TempRange_1 As String Private TempRange_2 As String Private TempString_1 As String Private TempString_2 As String Private TempNum1 As Variant Private TempNum2 As Variant Sub S01_SubCalls() ' This Excel macro was created to take a monthly Eaton labor distribution ' report and add that month's data to a cumulative yearly report. ' There are brief explanatory comments throughout the code, ' and there are some instructional notes in the last subroutine: S99_Notes. S03_Init S05_Show_Menu S09_Open_Files S11_TransferData If ErrorFlag2 = 1 Then Exit Sub S20_Save_and_Cleanup End Sub Sub S03_Init() ' Size and Position Macro Worksheet ActiveWindow.WindowState = xlNormal With ActiveWindow .Width = 220 .Height = 115 .Top = 1 .Left = 1 End With ' Do this because sometimes Excel doesn't clear variable values from previous runs For Loop1 = 1 To 22 GetDataArray(Loop1, 1) = "" Next Loop1 DataFileName = "" EmployeeLastName = "" ErrorFlag = "" ErrorFlag2 = "" ErrorFlag3 = "" FilesLocation = "" FilesLocationAndDataFileName = "" FilesLocationAndReportName = "" MonthOfTheYear = 0 ReportName = "" TempAddress1 = "" TempAddress2 = "" TempRange_1 = "" TempRange_2 = "" TempString_1 = "" TempString_2 = "" TempNum1 = "" TempNum2 = "" ' Load the user maintained data Sheets("Data").Select FilesLocation = Range("C2").Text DataFileName = Range("C3").Text ReportName = Range("C4").Text Sheets("Start Button").Select End Sub Sub S05_Show_Menu() ' Show Data Input form, confirm info Form_DataInput.Tbox_FilesLocation = FilesLocation Form_DataInput.TBox_LaborFileName = DataFileName Form_DataInput.TBox_ReportName = ReportName Form_DataInput.Show ' Show form ' Get file location and file name info, in case it has been changed FilesLocation = Form_DataInput.Tbox_FilesLocation DataFileName = Form_DataInput.TBox_LaborFileName ReportName = Form_DataInput.TBox_ReportName ' Save the info to the macro Data page Sheets("Data").Select Range("C2").Select ActiveCell.FormulaR1C1 = FilesLocation ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = DataFileName ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = ReportName Sheets("Start Button").Select ' Save the data (macro) ActiveWorkbook.Save ' Determine which month of the year the data is for TempNum1 = Len(DataFileName) TempString_1 = Mid(DataFileName, (TempNum1 - 7), 2) ' month MonthOfTheYear = TempString_1 ' convert string to integer ' Define data location and data file name FilesLocationAndDataFileName = FilesLocation + "\" + DataFileName ' Define report location and report name FilesLocationAndReportName = FilesLocation + "\" + ReportName End Sub Sub S09_Open_Files() ' Open Data File Workbooks.Open Filename:=FilesLocationAndDataFileName ' Size and Position Data Worksheet Window ActiveWindow.WindowState = xlNormal With ActiveWindow .Width = 230 .Height = 160 .Top = 25 .Left = 75 End With ' Open Report File Workbooks.Open Filename:=FilesLocationAndReportName ' Size and Position Report File Window ActiveWindow.WindowState = xlNormal With ActiveWindow .Width = 230 .Height = 160 .Top = 45 .Left = 180 End With End Sub Sub S11_TransferData() Application.ScreenUpdating = False ' turn off screen updating to make macro run faster Windows(DataFileName).Activate Range("A8").Select GetDataArray(1, 1) = ActiveCell.Value While GetDataArray(1, 1) > "" 'Do until macro finds a blank line EmployeeLastName = GetDataArray(1, 1) ' Load an employee's data into array For Loop2 = 1 To 22 GetDataArray(Loop2, 1) = ActiveCell.Value ActiveCell.Offset(0, 1).Select Next Loop2 ' Record location to begin next employees data loading TempAddress1 = ActiveCell.Offset(1, -22).Address ' Transfer data to report Windows(ReportName).Activate On Error GoTo NoTabFound: ' if no employee tab found, this error screen is shown Sheets(EmployeeLastName).Select On Error GoTo 0 ' reset error checking Range("B1").Select ' Move down rows the number of months + 5 ActiveCell.Offset((MonthOfTheYear + 5), 0).Select ' Notify user if there is already data in this row If ErrorFlag3 = "" Then '(just do this once per macro run) TempNum1 = ActiveCell.Value If TempNum1 > "" Then Form_Alert.Show ErrorFlag3 = 1 End If End If ' Write the data to the report For Loop2 = 2 To 22 ActiveCell.FormulaR1C1 = GetDataArray(Loop2, 1) ActiveCell.Offset(0, 1).Select Next Loop2 Range("A1").Select ' Go back to the Monthly Labor File worksheet to get next employee's data Windows(DataFileName).Activate Range(TempAddress1).Select GetDataArray(1, 1) = ActiveCell.Value ' This If statement is to bypass the blank line with "(EEN)" in employee name slot. If GetDataArray(1, 1) = "(EEN)" Then ActiveCell.Offset(1, 0).Select GetDataArray(1, 1) = ActiveCell.Value Wend Exit Sub NoTabFound: ' No employee worksheet is found Form_AlertTwo.Text1_UserAlert2 = GetDataArray(1, 1) Form_AlertTwo.Show ErrorFlag2 = 1 End Sub Sub S20_Save_and_Cleanup() ActiveWindow.Close Sheets("DOC Totals").Select Range("A1").Select ' Save the file (Not implemented at this time - let user decide whether to save file or not.) 'ActiveWorkbook.Save ' Fake the save ' ActiveWorkbook.Saved = True Application.ScreenUpdating = True ActiveWindow.WindowState = xlMaximized MsgBox ("The macro has completed.") End Sub Sub S99_Notes() ' Notes on this macro (05-20-06, by Rick Struble) ' Nothing additional to say really. The macro should work fine as long ' as there are no changes to the format of the incoming data. ' Each new employee will require that the user add a new worksheet in ' the yyyy_Labor_Utilization_Reports.xls. This is planned for and ' explained with an alert screen. End Sub Some good code, though not used in macro: ' Parse employee's last name Range("AB1").Select ActiveCell.FormulaR1C1 = GetDataArray(1, 1) Selection.TextToColumns Destination:=Range("AB1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True EmployeeLastName = ActiveCell.Value ActiveCell.FormulaR1C1 = "" ActiveCell.Offset(0, 1).Value = "" $$$$$ Rename Aiptek camera files Code $$$ October 10, 2004 Public FileNamesArray(99, 3) As String Public BeginningNum As Integer Public FinalNum As Integer Public Loop1 As Integer Public NewName As String Public SubRen As String Public SubSpace As String Public SubZero As String Public TempFileNumText As String Public TempInt1 As Integer Public TempInt2 As Integer Public TempRange1 As String Public TempVar1 As String Sub RenameFiles() ' Do this because Excel sometimes doesn't clear variable values from previous runs For Loop1 = 1 To 20 FileNamesArray(Loop1, 1) = "" FileNamesArray(Loop1, 2) = "" FileNamesArray(Loop1, 3) = "" Next Loop1 TempRange1 = "" JPGSuffix = "jpg" AVISuffix = "avi" SubRen = "Ren " SubSpace = " " SubZero = "0" SubPeriod = "." SubUnderScore = "_" ' FileNamesArray 1= original jpg file name 2= original avi file name 3= new file number Form_RenamingFiles.Show Application.ScreenUpdating = False ActiveWorkbook.Save NewName = Form_RenamingFiles.TextBox_NamingPrefix.Text BeginningNum = Form_RenamingFiles.TextBox_StartingNumber.Value FinalNum = Form_RenamingFiles.TextBox_NumberOfFiles.Value FinalNum = FinalNum + BeginningNum ' Read probable file names into array Sheets("ProbableNames").Select Range("A1").Select For Loop1 = BeginningNum To FinalNum TempVar1 = Selection.Text FileNamesArray(Loop1, 1) = TempVar1 ActiveCell.Offset(1, 0).Select Next Loop1 Range("B1").Select For Loop1 = BeginningNum To FinalNum TempVar1 = Selection.Text FileNamesArray(Loop1, 2) = TempVar1 ActiveCell.Offset(1, 0).Select Next Loop1 Range("A1").Select ' Start writing the new file names Sheets("CopyOutHere").Select Range("A1").Select TempInt1 = BeginningNum For Loop1 = BeginningNum To FinalNum TempFileNumText = Loop1 'Write jpg file names If TempInt1 < 10 Then ActiveCell.FormulaR1C1 = SubRen + FileNamesArray(Loop1, 1) + SubSpace + NewName + SubUnderScore + SubZero + TempFileNumText + SubPeriod + JPGSuffix ActiveCell.Offset(1, 0).Select Else ActiveCell.FormulaR1C1 = SubRen + FileNamesArray(Loop1, 1) + SubSpace + NewName + SubUnderScore + TempFileNumText + SubPeriod + JPGSuffix ActiveCell.Offset(1, 0).Select End If 'Write avi file names If TempInt1 < 10 Then ActiveCell.FormulaR1C1 = SubRen + FileNamesArray(Loop1, 2) + SubSpace + NewName + SubUnderScore + SubZero + TempFileNumText + SubPeriod + AVISuffix ActiveCell.Offset(1, 0).Select Else ActiveCell.FormulaR1C1 = SubRen + FileNamesArray(Loop1, 2) + SubSpace + NewName + SubUnderScore + TempFileNumText + SubPeriod + AVISuffix ActiveCell.Offset(1, 0).Select End If TempInt1 = TempInt1 + 1 Next Loop1 Range("A1").Select ActiveWorkbook.SaveAs Filename:="Rename.bat", _ FileFormat:=xlText, CreateBackup:=False ActiveWorkbook.Saved = True Application.ScreenUpdating = True MsgBox ("The macro has completed. Now run the batch file.") End Sub = = = = = $$$$$ Rename camera files Code $$$ August 21, 2004 Public FileNamesArray(99, 3) As String Public BeginningNum As Integer Public FinalNum As Integer Public Loop1 As Integer Public NewName As String Public SubRen As String Public SubSpace As String Public SubZero As String Public TempInt1 As Integer Public TempInt2 As Integer Public TempRange1 As String Public TempVar1 As String Sub RenameFiles() NewName = "Jul2004" BeginningNum = 1 FinalNum = BeginningNum + 99 SubRen = "Ren " SubSpace = " " SubZero = "0" SubPeriod = "." SubUnderScore = "_" ' FileNamesArray 1= original file name 2= file name suffix 3= new file number Application.ScreenUpdating = False ' Do this because Excel sometimes doesn't clear variable values from previous runs For Loop1 = 1 To 99 FileNamesArray(Loop1, 1) = "" FileNamesArray(Loop1, 2) = "" FileNamesArray(Loop1, 3) = "" Next Loop1 TempRange1 = "" Sheets("PasteInHere").Select Range("A1").Select ' Grab address of first filename TempRange1 = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False) ' Read the original file names into the array For Loop1 = 1 To 99 TempVar1 = Selection.Text If TempVar1 = "" Then Exit For FileNamesArray(Loop1, 1) = TempVar1 ActiveCell.Offset(1, 0).Select Next Loop1 ' Grab address of last filenames TempRange2 = ActiveCell.Offset(-1, 0).Address(RowAbsolute:=False, ColumnAbsolute:=False) ' Parse the suffix out of the filename Range(TempRange1, TempRange2).Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :=".", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True ' Convert to lower case Range("C1").Select For Loop1 = 1 To 99 ActiveCell.FormulaR1C1 = "=LOWER(RC[-1])" ActiveCell.Offset(1, 0).Select Next Loop1 ' Read the suffix file names into the array Range("C1").Select For Loop1 = 1 To 99 TempVar1 = Selection.Text If TempVar1 = "" Then Exit For FileNamesArray(Loop1, 2) = TempVar1 ActiveCell.Offset(1, 0).Select Next Loop1 ' Put the new numbers into a string array Range("C1").Select TempInt1 = BeginningNum For Loop1 = 1 To 99 ActiveCell.FormulaR1C1 = TempInt1 TempInt1 = TempInt1 + 1 ActiveCell.Offset(1, 0).Select Next Loop1 Range("C1").Select For Loop1 = 1 To 99 TempVar1 = Selection.Text If FileNamesArray(Loop1, 1) = "" Then Exit For FileNamesArray(Loop1, 3) = TempVar1 ActiveCell.Offset(1, 0).Select Next Loop1 ' Start writing the new file names Sheets("CopyOutHere").Select Range("A1").Select TempInt1 = BeginningNum For Loop1 = 1 To 99 If FileNamesArray(Loop1, 1) = "" Then Exit For If TempInt1 < 10 Then ActiveCell.FormulaR1C1 = SubRen + FileNamesArray(Loop1, 1) + SubSpace + NewName + SubUnderScore + SubZero + FileNamesArray(Loop1, 3) + SubPeriod + FileNamesArray(Loop1, 2) ActiveCell.Offset(1, 0).Select Else ActiveCell.FormulaR1C1 = SubRen + FileNamesArray(Loop1, 1) + SubSpace + NewName + SubUnderScore + FileNamesArray(Loop1, 3) + SubPeriod + FileNamesArray(Loop1, 2) ActiveCell.Offset(1, 0).Select End If TempInt1 = TempInt1 + 1 Next Loop1 ' Clean up Sheets("PasteInHere").Select Cells.Select Selection.ClearContents Range("A1").Select Sheets("CopyOutHere").Select Range("A1").Select Application.ScreenUpdating = True End Sub = = = = = = = = $$$$$ Qcom Macros Code $$$ ' flag declarations Public DailyFlag As Integer Public HtmlFlag As Integer Public LapTopFlag As Integer Public MenuFlag As Integer Public PrintFlag As Integer Public TotalsFlag As Integer Public TablesFlag As Integer ' directory location declarations Public DailyFlpLocation As String Public DataLocation As String Public GraphLocation As String Public HtmlLocation As String Public MacroLocation As String Public TablesLocation As String Public TemplateLocation As String ' misc variable declarations Public EndDay As String Public EndWeek As String Public FlpFrom As Integer Public FlpTo As Integer Public Graphs As Integer Public LoopFrom As Integer Public LoopTo As Integer Public PollFrom As Integer Public PollTo As Integer Public StartDay As String Public SysNum As String Public TotalNumOfSys As Integer Public WeekFrom As Integer Public WeekTo As Integer ' file name declarations Public GraphsAndWorksheets As String Public GraphsAndWorksheetsSave As String Public GraphsandWorksheetsTemplateOpen As String Public MacroFileName As String Public VaxFile1Import Public VaxFile2Import Public VaxFile3Import Public VaxFile4Import Public VaxFile1ImportOpen As String Public VaxFile2ImportOpen As String Public VaxFile3ImportOpen As String Public VaxFile4ImportOpen As String Public M3_VaxFile1 As String Public M3_Template As String Public M3_Workbook As String Public M4_VaxFile1 As String Public M5_VaxFile1 As String Public M5_VaxFile2 As String Public M5_VaxFile3 As String Public M5_Template As String Public M5_Workbook1 As String Public M5_Workbook2 As String Public M6_VaxFile1 As String Public M6_VaxFile2 As String Public M6_VaxFile3 As String Public M6_VaxFile4 As String Public M6_Template As String Public M6_Workbook As String Public M7_Template As String Public M7_Workbook As String Public m9_Template As String Public m11_Template As String Public m12_Template As String Public m12_Workbook As String Sub Mod2Sub1_InitSetup() 'This module does the initial housekeeping chores, ' and brings up the user menu. LapTopFlag = 0 'laptop uses different file locations and window sizes ' Mod2Sub2_ManualGraphing (called only when Graphing Menu button is clicked) Mod2Sub3_FileNamesAndLocations Mod2Sub4_MiscItems Mod2Sub5_GetDatesWeekly If TablesFlag = 1 Then Exit Sub Mod2Sub6_GetDatesDaily ' Mod2Sub7_ for future macros ' Mod2Sub8_ for future macros Mod2Sub9_Menu End Sub Sub Mod2Sub2_ManualGraphing() ' This sub is only called when the Graphing Menu button is clicked. If and when ' the graphing macro is run without user intervention, this sub will be omitted. ' reset all flags, as they sometimes aren't reset as they should be (VB bug?) DailyFlag = 0 HtmlFlag = 0 PrintFlag = 0 TotalsFlag = 0 TablesFlag = 0 WeekFrom = 0 FlpFrom = 0 PollFrom = 0 MenuFlag = 1 'lets macro know that user needs to see the graphing menu Form_TopLevelMenu.Show End Sub Sub Mod2Sub3_FileNamesAndLocations() ' This is where the macro and data file names and locations are defined. ' Define locations where the macro will read/write to and from: If LapTopFlag = 0 Then ' if using a desktop networked computer MacroFileName = "OmniGraphingMacro.xls" MacroLocation = "Y:\Public\Graphs\_Macros\" DataLocation = "Y:\public\graphs\_data\" DailyFlpLocation = "Y:\public\graphs\_DailyFLP\" GraphLocation = "Y:\public\graphs\_graphs\" HtmlLocation = "Y:\public\graphs\_html\" TablesLocation = "Y:\public\graphs\_Tables\" TemplateLocation = "Y:\public\graphs\_templates\" Else ' if using the laptop or not connected to network MacroFileName = "OmniGraphingMacro.xls" MacroLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Macros\" DataLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Data\" DailyFlpLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_data_daily\" GraphLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Graphs\" HtmlLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Html\" TablesLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Tables\" TemplateLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Templates\" End If ' Names of the Data Files the macro will open: ' (If a system number is part of the file name, it is ' defined in the Init sub of the module itself.) ' Module 3: WeeklyDailyMacro M3_VaxFile1 = "_Nmc.txt" M3_Template = "zz WeeklyDailyBar Graphs Template.xls" M3_Workbook = "WeeklyDailyBar Graphs Sys" ' Module 4: BarChartMacro M4_VaxFile1 = "_Bar.txt" ' Module 5: FlpRlpMacro M5_VaxFile1 = "_Fli.txt" M5_VaxFile2 = "_Rtn.txt" M5_VaxFile3 = "DailyFLi" 'M5_VaxFile3 = "DailyFLP_" M5_Template = "zz FlpRlp Graphs Template.xls" M5_Workbook1 = "FlpRlp Graphs Sys" M5_Workbook2 = "DailyFLP_" ' Module 6: PollClassMacro M6_VaxFile1 = "PC2.txt" M6_VaxFile2 = "PC3.txt" M6_VaxFile3 = "_high_pc.txt" M6_VaxFile4 = "_Summary.txt" 'M6_VaxFile3 = "_PCHighCount.txt" 'M6_VaxFile4 = "_PCRlrSumm.txt" M6_Template = "zz PollClass Graphs Template.xls" M6_Workbook = "PollClass Graphs Sys" ' Module 7: HtmlConversionMacro M7_Template = "zz Html Template.xls" ' m7_workbook = must be defined in Mod__7, because the macro doesn't ' know the date yet at this point ' Module 9: HtmlConversionFlpDaily m9_Template = "zz HtmlDaily Template.xls" ' Module 11: WklyRptTablesMacro m11_Template = "zz WklyRptTables Template.xls" ' Module 12: TotalsMacro m12_Template = "zz Blank Workbook.xls" m12_Workbook = "Total Message Count " End Sub Sub Mod2Sub4_MiscItems() ' This is the number of Omni systems the macro will assume have provided data. TotalNumOfSys = 8 ' This sizes and positions the Excel macro itself Windows(MacroFileName).Activate ActiveWindow.WindowState = xlNormal With ActiveWindow .Width = 175 .Height = 95 If LapTopFlag = 0 Then 'using desktop networked computer .Top = 300 .Left = 362 Else ' using laptop or non-networked computer .Top = 200 .Left = 200 End If End With End Sub Sub Mod2Sub5_GetDatesWeekly() ' This sub opens one of the weekly data files and gets the date range of the data. ' These dates are then displayed on the Graphing Menu ' so the user can verify that the data files are the correct ones. ' If the data file can't be found, the menu prompts the users to enter ' beginning and ending dates and the macro then uses those dates. Application.ScreenUpdating = False If DailyFlag = 1 Then Exit Sub 'If doing daily FLP graphing, use different Subroutine. VaxFile1Import = "Sys1" + M3_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import On Error GoTo NoData: Workbooks.OpenText Filename:= _ VaxFile1ImportOpen _ , Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(10, 1), Array(18, 1), Array(30, 1), _ Array(43, 1), Array(54, 1), Array(66, 1)) On Error GoTo 0 Columns("A:A").ColumnWidth = 20 Range("A1:A5").Select Selection.EntireRow.Insert ' Get beginning of week date Range("A12").Select Selection.Copy Range("A1").Select ActiveSheet.Paste Range("A1").Select Selection.NumberFormat = "mmmm d" StartDay = ActiveCell.Text ' Get end of week date Range("A179").Select Application.CutCopyMode = False Selection.Copy Range("A2").Select ActiveSheet.Paste Selection.NumberFormat = "mmmm d, yyyy" EndDay = ActiveCell.Text Selection.Copy Range("A3").Select ActiveSheet.Paste Selection.NumberFormat = "mmddyy" EndWeek = ActiveCell.Text ' Done with the data file, close it ActiveWorkbook.Saved = True ActiveWindow.Close Application.ScreenUpdating = True Exit Sub ' If no data file was found, make alert text and date input fields visible on menu. NoData: Form_GraphingMenu.Lbl_WeekOf.Visible = False Form_GraphingMenu.Lbl_NoDataLabel1.Visible = True Form_GraphingMenu.Lbl_NoDataLabel2.Visible = True Form_GraphingMenu.Txt_WeekStart.Visible = True Form_GraphingMenu.Txt_WeekEnd.Visible = True End Sub Sub Mod2Sub6_GetDatesDaily() ' This sub is used when doing the daily FLP graphing. ' Using the current date (as shown on the computer, so this must be set correctly) ' then automatically calculates the current weeks date range. If DailyFlag = 0 Then Exit Sub Application.ScreenUpdating = False Workbooks.Add Columns("A:A").ColumnWidth = 20 Columns("B:B").ColumnWidth = 20 Range("A1").Select ActiveCell.FormulaR1C1 = "=NOW()" Selection.NumberFormat = "ddd" Let TempVar = ActiveCell.Text Range("A2").Select Select Case TempVar ' Case "Mon" ' ActiveCell.FormulaR1C1 = "=R[-1]C" Case "Tue" ActiveCell.FormulaR1C1 = "=R[-1]C-1" Case "Wed" ActiveCell.FormulaR1C1 = "=R[-1]C-2" Case "Thu" ActiveCell.FormulaR1C1 = "=R[-1]C-3" Case "Fri" ActiveCell.FormulaR1C1 = "=R[-1]C-4" Case "Sat" ActiveCell.FormulaR1C1 = "=R[-1]C-5" Case "Sun" ActiveCell.FormulaR1C1 = "=R[-1]C-6" End Select Range("A2").Select Selection.NumberFormat = "mmmm dd" StartDay = ActiveCell.Text Range("A3").Select ActiveCell.FormulaR1C1 = "=R[-1]C+6" Selection.NumberFormat = "mmmm dd, yyyy" EndDay = ActiveCell.Text Range("A4").Select ActiveCell.FormulaR1C1 = "=R[-1]C" Selection.NumberFormat = "mmddyy" EndWeek = ActiveCell.Text ActiveWorkbook.Saved = True ActiveWindow.Close Application.ScreenUpdating = True End Sub Sub Mod2Sub9_Menu() ' This sub fills the menu drop down boxes and then displays the menu If DailyFlag = 1 Then Exit Sub 'if doing daily FLP graphing, no need to show menu If MenuFlag = 0 Then Exit Sub ' if macro running in batch, no need to show menu ' Clear out any previous loads Form_GraphingMenu.ComboBox_Weekly.Clear Form_GraphingMenu.ComboBox_FLP.Clear Form_GraphingMenu.ComboBox_Poll.Clear ' Add the choices in the drop down selection boxes Form_GraphingMenu.ComboBox_Weekly.AddItem "None" Form_GraphingMenu.ComboBox_Weekly.AddItem "All Systems" Form_GraphingMenu.ComboBox_FLP.AddItem "None" Form_GraphingMenu.ComboBox_FLP.AddItem "All Systems" Form_GraphingMenu.ComboBox_Poll.AddItem "None" Form_GraphingMenu.ComboBox_Poll.AddItem "All Systems" For LoadTest = 1 To TotalNumOfSys SysNum = LoadTest Form_GraphingMenu.ComboBox_Weekly.AddItem "System " + SysNum Form_GraphingMenu.ComboBox_FLP.AddItem "System " + SysNum Form_GraphingMenu.ComboBox_Poll.AddItem "System " + SysNum Next LoadTest ' This determines the default selection that will appear in the box (0 = 1st choice None) Form_GraphingMenu.ComboBox_Weekly.ListIndex = 1 Form_GraphingMenu.ComboBox_FLP.ListIndex = 1 Form_GraphingMenu.ComboBox_Poll.ListIndex = 1 Form_GraphingMenu.Lbl_WeekOf.Caption = " " & StartDay & " - " & EndDay & " " Form_GraphingMenu.Show 'show the menu ' If there wasn't anything already in beginning date variable, ' then use the user provided dates. If StartDay = "" Then StartDay = Form_GraphingMenu.Txt_WeekStart.Text EndDay = Form_GraphingMenu.Txt_WeekEnd.Text Workbooks.Add Columns("A:A").ColumnWidth = 20 Range("A1").Select ActiveCell.FormulaR1C1 = EndDay Selection.NumberFormat = "mmddyy" EndWeek = ActiveCell.Text ActiveWorkbook.Saved = True ActiveWindow.Close End If End Sub ================= Private ExitFlag As Integer Sub Mod3Sub1_WeeklyDailyMacro() Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules Mod3Sub2_CheckFlags If ExitFlag = 1 Then Exit Sub For Graphs = LoopFrom To LoopTo Mod3Sub3_Init Mod3Sub4_ImportAndPrepData Mod3Sub5_CreateWeeklyGraph Mod3Sub6_CreateDailyGraph Mod4Sub1_BarChartMacro ' Calls a separate module, ' although graphs are created in this module's worksheet Mod3Sub7_SizePositionGraph Mod3Sub8_CleanUp Next Graphs Application.ScreenUpdating = True End Sub Sub Mod3Sub2_CheckFlags() ' This sub checks various flags. If they're set it then sets the ExitFlag so this module ' will not run. It also sets the loop variable using info the user input at the menu, ' or if running in batch, it sets the loop to graph for all systems. If MenuFlag = 1 Then If WeekFrom = 0 Then ExitFlag = 1 If PrintFlag = 1 Then ExitFlag = 1 If HtmlFlag = 1 Then ExitFlag = 1 If DailyFlag = 1 Then ExitFlag = 1 LoopFrom = WeekFrom LoopTo = WeekTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If End Sub Sub Mod3Sub3_Init() ' This sub defines the file name variables. Each time through the loop, the file names ' change, in order to do each Omni system. SysNum is the variable doing this. SysNum = Graphs VaxFile1Import = "Sys" + SysNum + M3_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import GraphsAndWorksheets = M3_Workbook + SysNum + " Week of " + StartDay + ".xls" GraphsAndWorksheetsSave = GraphLocation + GraphsAndWorksheets GraphsandWorksheetsTemplateOpen = TemplateLocation + M3_Template End Sub Sub Mod3Sub4_ImportAndPrepData() ' This sub opens the relevant data file, copies the data to the worksheet, ' then parses and preps the data as needed. ' Open the Vax data file. Workbooks.OpenText Filename:= _ VaxFile1ImportOpen, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) ' Open the WeeklyDailyBar graph template Workbooks.Open Filename:=GraphsandWorksheetsTemplateOpen ' Save the template as this weeks WeeklyDailyBar graph worksheet ActiveWorkbook.SaveAs Filename:= _ GraphsAndWorksheetsSave _ , FileFormat:=xlNormal ' Copy the data from the Vax data file and paste it in the Vax import worksheet Windows(VaxFile1Import).Activate Columns("A:A").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("Vax Import Orig").Select Range("A1").Select ActiveSheet.Paste ActiveWindow.SelectedSheets.Visible = False Sheets("Vax Import").Select Range("A1").Select ActiveSheet.Paste ' This is to clear the clipboard. Range("K1").Select Selection.Copy ' Close the Vax data file Windows(VaxFile1Import).Activate ActiveWindow.Close ' Parse the data. Windows(GraphsAndWorksheets).Activate Range("A2").Select Selection.Cut Destination:=Range("B2") Range("A4:A5").Select Selection.TextToColumns Destination:=Range("A4"), DataType:= _ xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(17, 1), _ Array(29, 1), Array(41, 1), Array(51, 1), Array(63, 1)) Range("A5:F5").Select Selection.Cut Destination:=Range("B5:G5") Range("B5:G5").Select Range("A6").Select Selection.TextToColumns Destination:=Range("A6"), DataType:= _ xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(11, 1), Array(19, 1), _ Array(31, 1), Array(43, 1), Array(55, 1), Array(67, 1)) Range("A7").Select Range("A7:A174").Select Selection.TextToColumns Destination:=Range("A7"), DataType:= _ xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(10, 1), Array(18, 1), _ Array(29, 1), Array(41, 1), Array(55, 1), Array(67, 1)) Range("A175:A181").Select Selection.TextToColumns Destination:=Range("A175"), DataType:= _ xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(8, 1), Array(21, 1), _ Array(28, 1), Array(40, 1), Array(47, 1), Array(53, 1)) ' Clean-up and format the data. Range("A4:G181").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = xlHorizontal End With Range("A1").Select Range("A1:G181").Select Range("G181").Activate With Selection.Font .Name = "Arial" .FontStyle = "Regular" .Size = 8 End With ' Copy the data and paste into Weekly Graph Worksheet Range("A7:G174").Select Selection.Copy Sheets("Weekly Graph Wrksht").Select Range("A3").Select ActiveSheet.Paste End Sub Sub Mod3Sub5_CreateWeeklyGraph() ' Update the Weekly Graph Header WeekRange = "Weekly NMC Graph SYSTEM " + SysNum + " " + StartDay + " through " + EndDay Sheets("Weekly Graph").Select ActiveSheet.DrawingObjects("Text 2").Select Application.CutCopyMode = False Selection.Characters.Text = WeekRange ' Get daily message totals for top of Weekly graph Sheets("Vax Import").Select Range("C175:C181").Select Selection.NumberFormat = "#,##0" Range("E175:E181").Select Selection.NumberFormat = "#,##0" Range("G175:G181").Select Selection.NumberFormat = "#,##0" Columns("M:M").ColumnWidth = 22.43 Sheets("Vax Import").Select Range("G175").Select Let MonHigh = ActiveCell.Text Range("G176").Select Let TueHigh = ActiveCell.Text Range("G177").Select Let WedHigh = ActiveCell.Text Range("G178").Select Let ThuHigh = ActiveCell.Text Range("G179").Select Let FriHigh = ActiveCell.Text Range("G180").Select Let SatHigh = ActiveCell.Text Range("G181").Select Let SunHigh = ActiveCell.Text ' Pastes in high daily message numbers below day of the week Sheets("Weekly Graph").Select ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.DrawingObjects("Text 3").Select Selection.Characters.Text = MonHigh ActiveChart.DrawingObjects("Text 5").Select Selection.Characters.Text = TueHigh ActiveChart.DrawingObjects("Text 7").Select Selection.Characters.Text = WedHigh ActiveChart.DrawingObjects("Text 9").Select Selection.Characters.Text = ThuHigh ActiveChart.DrawingObjects("Text 11").Select Selection.Characters.Text = FriHigh ActiveChart.DrawingObjects("Text 13").Select Selection.Characters.Text = SatHigh ActiveChart.DrawingObjects("Text 14").Select Selection.Characters.Text = SunHigh ActiveChart.Deselect ActiveWindow.Visible = False Range("A1").Select ' Set Messages scale ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlValue).Select With ActiveChart.Axes(xlValue) ' .MinimumScaleIsAuto = True .MaximumScale = 45000 ' .MinorUnitIsAuto = True ' .MajorUnitIsAuto = True ' .Crosses = xlAutomatic ' .ReversePlotOrder = False ' .ScaleType = xlLinear End With ActiveChart.ChartArea.Select ActiveWindow.Visible = False End Sub Sub Mod3Sub6_CreateDailyGraph() ' Determine Highest Total Messages for the week and paste info into Daily Graph Sheets("Vax Import").Select Range("K1").Select ' Formula places highest total message count into cell K1 ActiveCell.FormulaR1C1 = "=MAX(R[174]C[-4]:R[180]C[-4])" HighestDaySearch = ActiveSheet.Range("K1").Value Range("A1").Select ' Find goes to the row of the highest total message count Cells.Find(What:=HighestDaySearch, after:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _ , MatchCase:=False).Activate ' Get all the info needed for the day of the highest total message count Let TotalMessages = ActiveCell.Text ActiveCell.Offset(0, -2).Select Let TotalPosPolls = ActiveCell.Text ActiveCell.Offset(0, -2).Select Let TotalCompPolls = ActiveCell.Text ' Get date of highest total messages ActiveCell.Offset(0, -2).Select Application.CutCopyMode = False Selection.Copy ' Paste the date into cell K2 and format as needed Range("K2").Select Selection.PasteSpecial Paste:=xlValues Selection.NumberFormat = "m/d/yyyy" HighestDateSearch = ActiveSheet.Range("K2").Value Range("A3").Select ' Find goes to the beginning of highest day's data, and copies ' all the data from that day to the Daily Graph Worksheet Cells.Find(What:=HighestDateSearch, after:=ActiveCell, LookIn:= _ xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False).Activate ActiveCell.Range(Cells(1, 1), Cells(24, 7)).Select Application.CutCopyMode = False Selection.Copy Sheets("Daily Graph Wrksht").Select Range("A3").Select ActiveSheet.Paste ' Get the highest day's date and format it for the Graph header Range("A3").Select Selection.Copy Range("K3").Select ActiveSheet.Paste Columns("K:K").ColumnWidth = 21 Application.CutCopyMode = False Selection.NumberFormat = "mmmm d, yyyy" Let HighestDay = ActiveCell.Text ' Update Header and Footer Variables DailyRange = "Daily NMC Graph with Position Polls " + HighestDay FooterText3 = "Total Position Polls " + TotalPosPolls FooterText2 = " - Total Completed Polls " + TotalCompPolls FooterText1 = " - Total Messages " + TotalMessages FooterText = FooterText3 + FooterText2 + FooterText1 ' Paste the Header and Footer info into the appropriate text boxes Sheets("Daily Graph").Select ActiveSheet.DrawingObjects("Text 2").Select Application.CutCopyMode = False Selection.Characters.Text = DailyRange ActiveSheet.DrawingObjects("Text 3").Select Selection.Characters.Text = FooterText Range("A1").Select ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.DrawingObjects("Text 1").Select Selection.Characters.Text = "SYSTEM " + SysNum ActiveChart.Deselect ' Set Messages scale ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlValue).Select With ActiveChart.Axes(xlValue) ' .MinimumScaleIsAuto = True .MaximumScale = 45000 ' .MinorUnitIsAuto = True ' .MajorUnitIsAuto = True ' .Crosses = xlAutomatic ' .ReversePlotOrder = False ' .ScaleType = xlLinear End With ActiveChart.ChartArea.Select ActiveWindow.Visible = False Range("A1").Select End Sub Sub Mod3Sub7_SizePositionGraph() ' Size and position the worksheet on the screen (stagger windows) If LapTopFlag = 0 Then TopWindow = SysNum * 15 LeftWindow = SysNum * 14 With ActiveWindow .Width = 200 .Height = 100 .Top = TopWindow .Left = LeftWindow End With Else ' if using the laptop, different window sizes and locations TopWindow = SysNum * 14 LeftWindow = SysNum * 7 With ActiveWindow .Width = 150 .Height = 90 .Top = TopWindow .Left = LeftWindow End With End If ActiveWorkbook.Save End Sub Sub Mod3Sub8_CleanUp() ' Deselect objects on Weekly, Daily, and Bar Graphs Sheets("Barchart Worksheet").Select Range("A1").Select Sheets("Daily Graph Wrksht").Select Range("A1").Select Sheets("Weekly Graph Wrksht").Select Range("A1").Select Sheets("Barchart Graph2").Select Range("A1").Select Sheets("Barchart Graph").Select Range("A1").Select Sheets("Daily Graph").Select Range("A1").Select Sheets("Weekly Graph").Select Range("A1").Select End Sub ============== Sub Mod4Sub1_BarChartMacro() ' Called from within the WeeklyDailyBar macro Mod4Sub2_Init Mod4Sub3_ImportAndPrepData Mod4Sub4_CreateBarGraphs End Sub Sub Mod4Sub2_Init() ' This sub defines the file name variables. Each time through the loop, the file names ' change, in order to do each Omni system. SysNum is the variable doing this. VaxFile1Import = "Sys" + SysNum + M4_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import GraphsAndWorksheets = M3_Workbook + SysNum + " Week of " + StartDay + ".xls" GraphsAndWorksheetsSave = GraphLocation + GraphsAndWorksheets End Sub Sub Mod4Sub3_ImportAndPrepData() ' This sub opens the relevant data file, copies the data to the worksheet, ' then parses and preps the data as needed. Workbooks.OpenText Filename:= _ VaxFile1ImportOpen, Origin _ :=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier _ :=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, _ FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array _ (5, 1), Array(6, 1), Array(7, 1), Array(8, 1)) 'Clean up the imported data ' Range("C7:G7").Select Selection.Cut Destination:=Range("D7:H7") Range("C16:F22").Select Selection.Cut Destination:=Range("D16:G22") Range("C14:F14").Select Selection.Cut Destination:=Range("D14:G14") Range("C14").Select Columns("C:C").ColumnWidth = 14.86 ' ' Enter category labels, delete unneeded rows and columns ' Range("G7").Select ActiveCell.FormulaR1C1 = "Data Bits" Range("H7").Select Selection.ClearContents Range("C8").Select ActiveCell.FormulaR1C1 = "Free Form" Range("C9").Select ActiveCell.FormulaR1C1 = "Macro" Range("C10").Select ActiveCell.FormulaR1C1 = "Multiseg" Range("C11:C12").Select Selection.EntireRow.Delete Range("C11").Select ActiveCell.FormulaR1C1 = "B+" Range("C12").Select ActiveCell.FormulaR1C1 = "I poll" Range("C13").Select ActiveCell.FormulaR1C1 = "Return Ack" Range("C14").Select ActiveCell.FormulaR1C1 = "Param Set" Range("C15").Select Selection.EntireRow.Delete ActiveCell.FormulaR1C1 = "S Poll" Range("C16").Select ActiveCell.FormulaR1C1 = "Version" Range("C17").Select ActiveCell.FormulaR1C1 = "Pos Poll" Range("C18").Select ActiveCell.FormulaR1C1 = "Group" Range("C19").Select ActiveCell.FormulaR1C1 = "Macro Def" Range("A20:L46").Select Selection.EntireRow.Delete Range("E1:F1").Select Selection.EntireColumn.Delete Range("F1").Select Selection.EntireColumn.Delete Range("A1:B1").Select Selection.EntireColumn.Delete Range("C5").Select Selection.ClearContents Range("A1:A4").Select Selection.EntireRow.Delete ' ' Move and then copy data ' Range("A4:A15").Select Selection.Copy Range("A20").Select ActiveSheet.Paste Range("C3:C15").Select Application.CutCopyMode = False Selection.Cut Range("B19").Select ActiveSheet.Paste ' Copy Range("B1:B34").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("Barchart Worksheet").Select Range("C1").Select ActiveSheet.Paste Windows(VaxFile1Import).Activate Range("A1").Select Selection.Copy ActiveWorkbook.Saved = True ActiveWorkbook.Close End Sub Sub Mod4Sub4_CreateBarGraphs() ' Get info for Header ' Find Highest Forward Hour message count and assign to HighestForwardMsg Sheets("Vax Import").Select Range("M1").Select ActiveCell.FormulaR1C1 = "=MAX(R[7]C[-10]:R[173]C[-10])" HighestForwardMsg = ActiveSheet.Range("M1").Value Range("M1").Select Selection.NumberFormat = "#,##0" HighestForwardMsgFormatted = ActiveSheet.Range("M1").Text Range("A1").Select Cells.Find(What:=HighestForwardMsg, after:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _ , MatchCase:=False).Activate ' Get Highest Forward Message Time and Date ActiveCell.Offset(0, -1).Select Let GmtHour = ActiveCell.Text ActiveCell.Offset(0, -1).Select Application.CutCopyMode = False Selection.Copy Range("M3").Select Selection.PasteSpecial Paste:=xlValues Selection.NumberFormat = "mmmm d, yyyy" Let BarDate = ActiveCell.Text ' Enter the date and time info on Bar Graph Header BarDateHeader3 = BarDate + " " BarDateHeader2 = GmtHour + ":00 GMT (1 HOUR)" BarDateHeader = BarDateHeader3 + BarDateHeader2 Sheets("Barchart Graph").Select ActiveSheet.Shapes("Text 7").Select Selection.Characters.Text = "Peak Forward Link Traffic Graphs" ActiveSheet.Shapes("Text 8").Select Selection.Characters.Text = "System " + SysNum ActiveSheet.DrawingObjects("Text 9").Select Selection.Characters.Text = BarDateHeader ActiveSheet.DrawingObjects("Text 10").Select Selection.Characters.Text = "Total Forward Messages Only = " + HighestForwardMsgFormatted Sheets("Barchart Graph2").Select ActiveSheet.DrawingObjects("Text 3").Select Selection.Characters.Text = "System " + SysNum ActiveSheet.DrawingObjects("Text 4").Select Selection.Characters.Text = BarDateHeader ActiveSheet.DrawingObjects("Text 5").Select Selection.Characters.Text = "Total Forward Messages Only = " + HighestForwardMsgFormatted End Sub ================= Private ExitFlag As Integer Private FliBegDate As String Private FliEndDate As String Private FLP1X As Variant Private FLP3X As Variant Private FLPCompare As Variant Private FLP1Xtext As String Private FLP3Xtext As String Private LastRowA As String Private LastRowB As String Private LastRowC As String Private LastRowE As String Private LastRowG As String Private LastRowH As String Private LastRowCompare As String Sub Mod5Sub1_FlpRlpMacro() Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules Mod5Sub2_CheckFlags If ExitFlag = 1 Then Exit Sub For Graphs = LoopFrom To LoopTo Mod5Sub3_Init Mod5Sub4_ImportAndPrepFlpData Mod5Sub5_CreateFlpGraph Mod5Sub6_ImportAndPrepRlpData Mod5Sub7_CreateRlpGraph DailySkip: 'When doing the DailyFLP graphing, the macro skips the RLP subs, comes here Mod5Sub8_SizePositionGraph Mod5Sub9_CleanUp Next Graphs Application.ScreenUpdating = True End Sub Sub Mod5Sub2_CheckFlags() ' This sub checks various flags. If they're set it then sets the ExitFlag so this module ' will not run. It also sets the loop variable using info the user input at the menu, ' or if running in batch, it sets the loop to graph for all systems. If DailyFlag = 1 Then LoopFrom = 1 LoopTo = TotalNumOfSys End If If DailyFlag = 1 Then Exit Sub If MenuFlag = 1 Then If FlpFrom = 0 Then ExitFlag = 1 If PrintFlag = 1 Then ExitFlag = 1 If HtmlFlag = 1 Then ExitFlag = 1 LoopFrom = FlpFrom LoopTo = FlpTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If End Sub Sub Mod5Sub3_Init() ' This sub defines the file name variables. Each time through the loop, the file names ' change, in order to do each Omni system. SysNum is the variable doing this. SysNum = Graphs If DailyFlag = 0 Then VaxFile1Import = "Sys" + SysNum + M5_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import VaxFile2Import = "Sys" + SysNum + M5_VaxFile2 VaxFile2ImportOpen = DataLocation + VaxFile2Import GraphsAndWorksheets = M5_Workbook1 + SysNum + " Week of " + StartDay + ".xls" GraphsAndWorksheetsSave = GraphLocation + GraphsAndWorksheets GraphsandWorksheetsTemplateOpen = TemplateLocation + M5_Template Else VaxFile1Import = M5_VaxFile3 + SysNum + ".txt" VaxFile1ImportOpen = DailyFlpLocation + VaxFile1Import GraphsAndWorksheets = M5_Workbook2 + SysNum + " Week of " + StartDay + ".xls" GraphsAndWorksheetsSave = DailyFlpLocation + GraphsAndWorksheets GraphsandWorksheetsTemplateOpen = TemplateLocation + M5_Template End If End Sub Sub Mod5Sub4_ImportAndPrepFlpData() ' This sub opens the relevant data file, copies the data to the worksheet, ' then parses and preps the data as needed. ' Open the Flp Vax data file Workbooks.OpenText Filename:= _ VaxFile1ImportOpen, Origin:=xlWindows, StartRow:=1, _ DataType:=xlFixedWidth, FieldInfo:=Array(0, 1) ' Open the FlpRlp graph template Workbooks.Open Filename:=GraphsandWorksheetsTemplateOpen ' Save the template as this weeks FlpRlp graph worksheet ActiveWorkbook.SaveAs Filename:= _ GraphsAndWorksheetsSave _ , FileFormat:=xlNormal ' Copy the data from the Vax data file and paste it in the worksheet Windows(VaxFile1Import).Activate Columns("A:A").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("FLP Text Orig").Select Range("A1").Select ActiveSheet.Paste ActiveWindow.SelectedSheets.Visible = False Sheets("FLP Worksheet").Select Range("A1").Select ActiveSheet.Paste ' This is to clear the clipboard Range("Z1").Select Selection.Copy ' Close the Vax data file Windows(VaxFile1Import).Activate ActiveWindow.Close ' Parse the FLP data Sheets("FLP Worksheet").Select Columns("A:A").Select Application.CutCopyMode = False Selection.TextToColumns Destination:=Range("A1"), DataType:= _ xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _ :=False, Tab:=True, Semicolon:=False, Comma:=False, Space _ :=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _ Array(3, 1), Array(4, 1), Array(5, 1)) ' Columns("B:B").Select Application.CutCopyMode = False Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)) ' Clean-up and format the data Range("A1").Select Selection.EntireRow.Insert Range("A2").End(xlDown).Select LastRowA = Selection.Address 'variable for last row of data Range("B1").Select Selection.EntireColumn.Insert Selection.EntireColumn.Insert Range("A1").Select ActiveCell.FormulaR1C1 = "=""T""" Range(LastRowA).Select ActiveCell.Offset(, columnOffset:=1).Activate LastRowB = Selection.Address ActiveCell.Offset(, columnOffset:=1).Activate LastRowC = Selection.Address Range("B2", LastRowC).Name = "T" Range("B1").Select ActiveCell.FormulaR1C1 = "=""Hour""" Range("B2").Select ActiveCell.FormulaR1C1 = "0" Range("B3").Select ActiveCell.FormulaR1C1 = "=RC[-1]-R2C1" Range("B3", LastRowB).Select Selection.FillDown Range("B2").Select Range("B2", LastRowB).Name = "Hour" Range("C2").Select ActiveCell.FormulaR1C1 = "=SUM(Hour/60)" Range("C2", LastRowC).Select Selection.FillDown Columns("C:C").Select Selection.NumberFormat = "0" Range("D1").Select ActiveCell.FormulaR1C1 = "=""Address Chan""" Range("E1").Select ActiveCell.FormulaR1C1 = "=""1x Data Chan""" Range("F1").Select ActiveCell.FormulaR1C1 = "=""3x Data Chan""" Range("G1").Select ActiveCell.FormulaR1C1 = "=""Determ RLRs""" Columns("D:D").Select Selection.Insert Shift:=xlToRight Selection.Insert Shift:=xlToRight Range("Z7").Select ActiveCell.FormulaR1C1 = EndDay Range("Z6").Select ActiveCell.FormulaR1C1 = "=R[1]C-1" Range("Z1:Z6").Select Range("Z6").Activate Selection.FillUp Range("Z1").Select Selection.Copy Range("D2").Select Selection.PasteSpecial Paste:=xlValues Columns("D:D").ColumnWidth = 13.29 Columns("D:D").Select Application.CutCopyMode = False Selection.NumberFormat = "0" Range("D2").Select Range("E2").Select ActiveCell.FormulaR1C1 = "=RC[-1]+RC[-2]/1440" Columns("E:E").Select Selection.NumberFormat = "dd-mmm-yy hh:mm" Selection.ColumnWidth = 23 With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = xlHorizontal End With Range(LastRowA).Select ActiveCell.Offset(, columnOffset:=4).Activate LastRowE = Selection.Address ActiveCell.Offset(, columnOffset:=2).Activate LastRowG = Selection.Address ActiveCell.Offset(, columnOffset:=1).Activate LastRowH = Selection.Address Range("D2", LastRowE).Select Selection.FillDown Range("E1", LastRowH).Select Application.CutCopyMode = False Range("D2").Select FliBegDate = Selection.Value FliEndDate = FliBegDate + 7 ' Manual way of getting highest percentage number for each data rate ' (use this until I can figure out how to get MAX formula to accept ' a variable for a location) Range("G2").Select FLP1X = ActiveCell.FormulaR1C1 PerCentLoop1X: ActiveCell.Offset(RowOffset:=1, columnOffset:=0).Activate LastRowCompare = Selection.Address FLPCompare = ActiveCell.FormulaR1C1 If FLP1X < FLPCompare Then FLP1X = FLPCompare If LastRowCompare = LastRowG Then Range("H2").Select FLP3X = ActiveCell.FormulaR1C1 GoTo PerCentLoop3X Else GoTo PerCentLoop1X End If PerCentLoop3X: ActiveCell.Offset(RowOffset:=1, columnOffset:=0).Activate LastRowCompare = Selection.Address FLPCompare = ActiveCell.FormulaR1C1 If FLP3X * 10 < FLPCompare * 10 Then FLP3X = FLPCompare ' *10 added in above line due to inexplicable error in comparing ' numbers under 10. This seemed to fix it. If LastRowCompare = LastRowH Then GoTo EndLoops Else GoTo PerCentLoop3X End If EndLoops: ' FLP1Xtext = FLP1X ' FLP3Xtext = FLP3X ' Range(LastRowG).Select ' ActiveCell.Offset(RowOffset:=2, columnOffset:=0).Activate ' ActiveCell.Formula = "=MAX(g2:LastRowG)" End Sub Sub Mod5Sub5_CreateFlpGraph() Sheets("FLP Graph").Select ActiveSheet.ChartObjects.Add(5.25, 66, 563, 409).Select Application.CutCopyMode = False ActiveChart.ChartWizard Source:=Sheets("FLP Worksheet").Range("E1", LastRowH), _ Gallery:=xlXYScatter, Format:=1, PlotBy:=xlColumns, _ CategoryLabels:=1, SeriesLabels:=1, HasLegend:=1, Title:="", _ CategoryTitle:="", ValueTitle:="", ExtraTitle:="" ActiveSheet.DrawingObjects("Chart 1").Select Selection.Border.LineStyle = xlNone ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Position = xlBottom Selection.Left = 193 With Selection.Interior .ColorIndex = 15 'gray .PatternColorIndex = 1 .Pattern = xlSolid End With ' --------------- start new legend stuff here ActiveChart.Legend.LegendEntries(1).LegendKey.Select With Selection.Border .ColorIndex = 1 .Weight = xlThin .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 2 .MarkerForegroundColorIndex = 3 .MarkerStyle = xlDiamond .Smooth = False .MarkerSize = 5 .Shadow = False End With ActiveChart.Legend.LegendEntries(2).LegendKey.Select With Selection.Border .ColorIndex = 1 .Weight = xlThin .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 6 .MarkerForegroundColorIndex = 1 .MarkerStyle = xlSquare .Smooth = False .MarkerSize = 5 .Shadow = False End With ActiveChart.Legend.LegendEntries(3).LegendKey.Select With Selection.Border .ColorIndex = 1 .Weight = xlThin .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 2 .MarkerForegroundColorIndex = 41 .MarkerStyle = xlCircle .Smooth = False .MarkerSize = 5 .Shadow = False End With ' --------------- end new legend stuff here ActiveChart.Axes(xlCategory).Select With Selection.TickLabels.Font .Name = "Arial" .FontStyle = "Regular" .Size = 10 End With ActiveChart.Legend.Select With Selection.Font .Name = "Arial" .FontStyle = "Regular" .Size = 10 End With ActiveChart.PlotArea.Select Selection.Interior.ColorIndex = 2 Selection.Width = 582 ActiveChart.Axes(xlValue).Select With ActiveChart.Axes(xlValue) .MinimumScaleIsAuto = True .MaximumScale = 100 End With ' ActiveChart.SeriesCollection(1).Select ' With Selection.Border ' .ColorIndex = 1 ' .Weight = xlThin ' .LineStyle = xlContinuous ' End With ' ' ActiveChart.SeriesCollection(2).Select ' With Selection ' .MarkerBackgroundColorIndex = 2 ' .MarkerForegroundColorIndex = 26 ' End With ' With Selection.Border ' .ColorIndex = 1 ' .Weight = xlThin ' .LineStyle = xlContinuous ' End With ' ' ActiveChart.SeriesCollection(3).Select ' With Selection.Border ' .Weight = xlHairline ' .LineStyle = xlNone ' End With ' With Selection ' .MarkerBackgroundColorIndex = 15 ' .MarkerForegroundColorIndex = 3 ' .MarkerStyle = xlCircle ' .Smooth = False ' End With ' With Selection.Border ' .ColorIndex = 1 ' .Weight = xlThin ' .LineStyle = xlContinuous ' End With ActiveChart.Deselect ActiveWindow.Visible = False ' Update FLP graph headers WeekRange = "FLP Statistics " + StartDay + " through " + EndDay If DailyFlag = 1 Then WeekRange = "Daily " + WeekRange ActiveSheet.TextBoxes.Add(3, 1.5, 617.25, 21.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = WeekRange With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 2").Select Selection.Border.LineStyle = xlNone ActiveSheet.TextBoxes.Add(3, 47, 617.25, 21.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "SYSTEM " + SysNum With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 3").Select Selection.Border.LineStyle = xlNone Range("A1").Select ' Create axes titles and other text boxes ActiveSheet.TextBoxes.Add(3.75, 135.75, 21.75, 177.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "% IN USE" With Selection.Characters(Start:=1, Length:=10).Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter Selection.VerticalAlignment = xlCenter Selection.Orientation = xlVertical Selection.AutoSize = False Selection.Border.LineStyle = xlNone Range("A1").Select With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With ' Commented out because it sometimes causes macro to bomb. ' ActiveSheet.PageSetup.PrintArea = "" ' With ActiveSheet.PageSetup ' .CenterHeader = "" ' .CenterFooter = "" ' End With ActiveSheet.TextBoxes.Add(5.25, 512.25, 615, 20.25).Select Selection.Interior.ColorIndex = 2 ActiveWindow.LargeScroll ToRight:=-1 Selection.Characters.Text = "Qualcomm Proprietary" With Selection.Characters(Start:=1, Length:=20).Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter Selection.Border.LineStyle = xlNone ' Add 1X and 3X high % text boxes ActiveSheet.TextBoxes.Add(500, 445, 82, 12.75).Select 'ActiveSheet.TextBoxes.Add(509, 445, 77, 12.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "Highest % 1X = " + FLP1X + " Highest % 3X = " + FLP3X With Selection.Characters.Font .Name = "Arial" .FontStyle = "Regular" .Size = 8 End With Selection.ShapeRange.ScaleHeight 1.94, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Text 6").Select Selection.ShapeRange.IncrementLeft -19.5 Selection.ShapeRange.IncrementTop 5.25 Selection.HorizontalAlignment = xlCenter ' Set axes scale ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlCategory).Select With ActiveChart.Axes(xlCategory) .MinimumScale = FliBegDate .MaximumScale = FliEndDate .MinorUnitIsAuto = True .MajorUnitIsAuto = True .Crosses = xlAutomatic .ReversePlotOrder = False .ScaleType = xlLinear End With ' Add line at 90% mark Range("A1").Select ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Lines.Add(44.25, 48, 518, 48).Select With Selection.Border .LineStyle = xlDot .ColorIndex = 1 .Weight = xlHairline End With ' Remove Chart Border ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select With Selection.Border .Weight = 1 .LineStyle = 0 End With Range("A1").Select ActiveWindow.LargeScroll Down:=-2 Range("A1").Select End Sub Sub Mod5Sub6_ImportAndPrepRlpData() ' This sub opens the relevant data file, copies the data to the worksheet, ' then parses and preps the data as needed. If DailyFlag = 1 Then Exit Sub ' Open Rlp Vax data file Workbooks.OpenText Filename:= _ VaxFile2ImportOpen, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) ' Copy Vax data to worksheet Windows(VaxFile2Import).Activate Columns("A:A").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("RLP text orig").Select Range("A1").Select ActiveSheet.Paste ActiveWindow.SelectedSheets.Visible = False Sheets("RLP Worksheet").Select Range("A1").Select ActiveSheet.Paste ' This is to clear the clipboard Range("Z1").Select Selection.Copy ' Close the Vax data file Windows(VaxFile2Import).Activate ActiveWindow.Close ' Parse the data Sheets("RLP Worksheet").Select Columns("A:A").Select Application.CutCopyMode = False Selection.TextToColumns Destination:=Range("A1"), DataType:= _ xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _ :=False, Tab:=True, Semicolon:=False, Comma:=False, Space _ :=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array _ (5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)) ' Clean-up and format the data Columns("A:A").ColumnWidth = 12.57 Columns("E:E").ColumnWidth = 13.14 Rows("1:1").Select Selection.Insert Shift:=xlDown Columns("B:B").Select Selection.Insert Shift:=xlToRight Selection.Insert Shift:=xlToRight Range("A2").End(xlDown).Select LastRowA = Selection.Address ActiveCell.Offset(, columnOffset:=1).Activate LastRowB = Selection.Address ActiveCell.Offset(, columnOffset:=1).Activate LastRowC = Selection.Address ActiveCell.Offset(, columnOffset:=2).Activate LastRowE = Selection.Address ActiveCell.Offset(RowOffset:=-1, columnOffset:=3).Activate LastRowH = Selection.Address Range("B2").Select ActiveCell.FormulaR1C1 = "=R[1]C[-1]-R2C1" Range("B2", LastRowB).Select Selection.FillDown Range("B1").Select ActiveCell.FormulaR1C1 = "h" Range("C2").Select ActiveCell.FormulaR1C1 = "=SUM(R[2]C[5]/60)" Range("B2", LastRowB).Name = "h" Range("C1").Select Selection.ClearContents Range("C2").Select ActiveCell.FormulaR1C1 = "=SUM(h/60)" Columns("C:C").Select Selection.NumberFormat = "0" Range("C2", LastRowC).Select Selection.FillDown Range("D1").Select Selection.EntireColumn.Insert Range("D2").Select Sheets("FLP Worksheet").Select Range("Z1").Select Selection.Copy Sheets("RLP Worksheet").Select Range("D2").Select Selection.PasteSpecial Paste:=xlValues Range("E2").Select Selection.EntireColumn.Insert ActiveCell.FormulaR1C1 = "=RC[-1]+RC[-2]/1440" Columns("E:E").Select Selection.NumberFormat = "dd-mmm-yy hh:mm" Selection.ColumnWidth = 17.71 Range("D2", LastRowE).Select Selection.FillDown Range("F1").Select ' This truncate was added because the stats show ' a decimal percentage over 100%, which is impossible Range("H1").Select Selection.EntireColumn.Insert Range("H2").Select ActiveCell.FormulaR1C1 = "=TRUNC(RC[1])" Range("H2", LastRowH).Select Selection.FillDown Range("F1").Select ActiveCell.FormulaR1C1 = "Determ RLRs" Range("G1").Select ActiveCell.FormulaR1C1 = "B+ Determ Chan" Range("H1").Select ActiveCell.FormulaR1C1 = "B+ Prob Chan" Range("E1", LastRowH).Select End Sub Sub Mod5Sub7_CreateRlpGraph() If DailyFlag = 1 Then Exit Sub Sheets("RLP Graph").Select ActiveSheet.ChartObjects.Add(5.25, 66, 563, 409).Select Application.CutCopyMode = False ActiveChart.ChartWizard Source:=Sheets("RLP Worksheet").Range("E1", LastRowH), _ Gallery:=xlXYScatter, Format:=1, PlotBy:=xlColumns, _ CategoryLabels:=1, SeriesLabels:=1, HasLegend:=1, Title:="", _ CategoryTitle:="", ValueTitle:="", ExtraTitle:="" ActiveSheet.DrawingObjects("Chart 1").Select Selection.Border.LineStyle = xlNone ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Position = xlBottom Selection.Left = 193 Selection.Top = 387 ActiveChart.Axes(xlCategory).Select With Selection.TickLabels.Font .Name = "Arial" .FontStyle = "Regular" .Size = 10 End With ActiveChart.Legend.Select With Selection.Font .Name = "Arial" .FontStyle = "Regular" .Size = 10 End With ActiveChart.PlotArea.Select Selection.Interior.ColorIndex = 2 Selection.Width = 582 ActiveChart.Axes(xlValue).Select With ActiveChart.Axes(xlValue) .MinimumScaleIsAuto = True .MaximumScale = 100 End With ' ---------- start new legend colors here ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlAutomatic End With Selection.Shadow = False With Selection.Interior .ColorIndex = 15 .PatternColorIndex = 1 .Pattern = xlSolid End With ActiveChart.Legend.LegendEntries(1).LegendKey.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With With Selection .MarkerBackgroundColorIndex = 2 .MarkerForegroundColorIndex = 3 .MarkerStyle = xlDiamond .Smooth = False .MarkerSize = 5 .Shadow = False End With ActiveChart.Legend.LegendEntries(2).LegendKey.Select With Selection.Border .ColorIndex = 1 .Weight = xlThin .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 6 .MarkerForegroundColorIndex = 1 .MarkerStyle = xlSquare .Smooth = False .MarkerSize = 5 .Shadow = False End With ActiveChart.Legend.LegendEntries(3).LegendKey.Select With Selection.Border .ColorIndex = 1 .Weight = xlThin .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 2 .MarkerForegroundColorIndex = 41 .MarkerStyle = xlSquare .Smooth = False .MarkerSize = 5 .Shadow = False End With ActiveWindow.Visible = False ' ---------- end new legend colors here ' ActiveChart.SeriesCollection(2).Select ' With Selection.Border ' .ColorIndex = 1 ' .Weight = xlThin ' .LineStyle = xlContinuous ' End With '' With Selection ' .MarkerBackgroundColorIndex = 2 ' .MarkerForegroundColorIndex = 26 ' .MarkerStyle = xlSquare ' .Smooth = False ' End With ' ActiveChart.SeriesCollection(3).Select ' With Selection.Border ' .ColorIndex = 1 ' .Weight = xlThin ' .LineStyle = xlContinuous ' End With ' ActiveChart.SeriesCollection(3).Select ' With Selection.Border ' .ColorIndex = 1 ' .Weight = xlThin ' .LineStyle = xlContinuous ' End With ' With Selection ' .MarkerBackgroundColorIndex = 3 ' .MarkerForegroundColorIndex = 3 ' .MarkerStyle = xlCircle ' .Smooth = False ' End With ' ActiveChart.SeriesCollection(1).Select ' With Selection.Border ' .Weight = xlHairline ' .LineStyle = xlNone ' End With ' ActiveChart.Deselect ' ActiveWindow.Visible = False ' Update Rlp graph header WeekRange2 = "Return Link Statistics " + StartDay + " through " + EndDay ActiveSheet.TextBoxes.Add(3, 1.5, 617.25, 21.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = WeekRange2 With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 2").Select Selection.Border.LineStyle = xlNone ' Create other text boxes and axes titles ActiveSheet.TextBoxes.Add(3, 47, 617.25, 21.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "SYSTEM " + SysNum With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 3").Select Selection.Border.LineStyle = xlNone Range("A1").Select ActiveSheet.TextBoxes.Add(3.75, 135.75, 21.75, 177.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "% IN USE" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter Selection.VerticalAlignment = xlCenter Selection.Orientation = xlVertical Selection.AutoSize = False Selection.Border.LineStyle = xlNone Range("A1").Select ActiveSheet.TextBoxes.Add(1.5, 473, 617.25, 15).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = _ "B+ Deterministic Channels = 51 B- Deterministic Channels = 4 Deterministic RLRs = 120" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 9 End With Selection.HorizontalAlignment = xlCenter Selection.VerticalAlignment = xlCenter Selection.Border.LineStyle = xlNone ActiveSheet.TextBoxes.Add(5.25, 512.25, 615, 20.25).Select Selection.Interior.ColorIndex = 2 ActiveWindow.LargeScroll ToRight:=-1 Selection.Characters.Text = "Qualcomm Proprietary" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter Selection.Border.LineStyle = xlNone With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With ' commented out because this keeps bombing - used to be okay ' ActiveSheet.PageSetup.PrintArea = "" ' With ActiveSheet.PageSetup ' .CenterHeader = "" ' .CenterFooter = "" ' End With ' Set axes scale ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlCategory).Select With ActiveChart.Axes(xlCategory) .MinimumScale = FliBegDate .MaximumScale = FliEndDate .MinorUnitIsAuto = True .MajorUnitIsAuto = True .Crosses = xlAutomatic .ReversePlotOrder = False .ScaleType = xlLinear End With ' Remove chart border ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select With Selection.Border .Weight = 1 .LineStyle = 0 End With Range("A1").Select End Sub Sub Mod5Sub8_SizePositionGraph() ' Size and position the worksheet on the screen (stagger windows) If LapTopFlag = 0 Then TopWindow = SysNum * 15 LeftWindow = 260 + (SysNum * 14) With ActiveWindow .Width = 200 .Height = 100 .Top = TopWindow .Left = LeftWindow End With Else 'If using the laptop, different window sizes and locations TopWindow = SysNum * 14 LeftWindow = 190 + (SysNum * 7) With ActiveWindow .Width = 150 .Height = 90 .Top = TopWindow .Left = LeftWindow End With End If ActiveWorkbook.Save End Sub Sub Mod5Sub9_CleanUp() ' Deselect FLP & RLP graph objects Sheets("RLP Worksheet").Select Range("A1").Select Sheets("FLP Worksheet").Select Range("A1").Select Sheets("RLP Graph").Select Range("A1").Select Sheets("FLP Graph").Select Range("A1").Select End Sub ============== Private ExitFlag As Integer Private MonDate As String Private TueDate As String Private WedDate As String Private ThuDate As String Private FriDate As String Private SatDate As String Private SunDate As String Private MonDay As String Private LastRowA As String Private LastRowB As String Private LastRowC As String Private LastRowE As String Private PC2BegDate As String Private PC2EndDate As String Private PC2HiDate As String Private PC2HiTime As String Private PC2HiValue As String Private PC3BegDate As String Private PC3EndDate As String Private PC3HiDate As String Private PC3HiTime As String Private PC3HiValue As String Sub Mod6Sub1_PollClassMacro() Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules Mod6Sub2_CheckFlags If ExitFlag = 1 Then Exit Sub For Graphs = LoopFrom To LoopTo Mod6Sub3_Init Mod6Sub4_ImportAndPrepPC2Data Mod6Sub5_CreatePC2Graph Mod6Sub6_ImportAndPrepPC3Data Mod6Sub7_CreatePC3Graph Mod6Sub8_ImportDataAndFillRlrForm Mod6Sub9_SizePositionGraph Mod6Subb10_CleanUp Next Graphs Application.ScreenUpdating = True End Sub Sub Mod6Sub2_CheckFlags() ' This sub checks various flags. If they're set it then sets the ExitFlag so this module ' will not run. It also sets the loop variable using info the user input at the menu, ' or if running in batch, it sets the loop to graph for all systems. If MenuFlag = 1 Then If PollFrom = 0 Then ExitFlag = 1 If PrintFlag = 1 Then ExitFlag = 1 If HtmlFlag = 1 Then ExitFlag = 1 LoopFrom = PollFrom LoopTo = PollTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If End Sub Sub Mod6Sub3_Init() ' This sub defines the file name variables. Each time through the loop, the file names ' change, in order to do each Omni system. SysNum is the variable doing this. SysNum = Graphs VaxFile1Import = "Sys" + SysNum + M6_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import VaxFile2Import = "Sys" + SysNum + M6_VaxFile2 VaxFile2ImportOpen = DataLocation + VaxFile2Import VaxFile3Import = "Sys" + SysNum + M6_VaxFile3 VaxFile3ImportOpen = DataLocation + VaxFile3Import VaxFile4Import = "Sys" + SysNum + M6_VaxFile4 VaxFile4ImportOpen = DataLocation + VaxFile4Import GraphsAndWorksheets = M6_Workbook + SysNum + " Week of " + StartDay + ".xls" GraphsAndWorksheetsSave = GraphLocation + GraphsAndWorksheets GraphsandWorksheetsTemplateOpen = TemplateLocation + M6_Template End Sub Sub Mod6Sub4_ImportAndPrepPC2Data() ' This sub opens the relevant data file, copies the data to the worksheet, ' then parses and preps the data as needed. Workbooks.OpenText Filename:= _ VaxFile1ImportOpen, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) Workbooks.Open Filename:=GraphsandWorksheetsTemplateOpen ActiveWorkbook.SaveAs Filename:= _ GraphsAndWorksheetsSave _ , FileFormat:=xlNormal Windows(VaxFile1Import).Activate Columns("A:A").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("Poll Class 2 text orig").Select Range("A1").Select ActiveSheet.Paste ActiveWindow.SelectedSheets.Visible = False Sheets("Poll Class 2 Worksheet").Select Range("A1").Select ActiveSheet.Paste ' this is to clear the clipboard: Range("Z1").Select Selection.Copy ' Done with the data file, close it Windows(VaxFile1Import).Activate ActiveWindow.Close ' Parse Poll Class 2 Sheets("Poll Class 2 Worksheet").Select Columns("A:A").Select Application.CutCopyMode = False ' use this TextToColumns when data is prepared by Steve Barrett's process Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)) ' use this TextToColumns when data is prepared by Rick Struble's DCL .com file ' Selection.TextToColumns Destination:=Range("A1"), DataType:= _ ' xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(8, 1), Array(16, 1), _ ' Array(30, 1)) ' this this TextToColumns when data is prepared manually with cut & paste ' Selection.TextToColumns Destination:=Range("A1"), DataType:= _ ' xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _ ' :=False, Tab:=True, Semicolon:=False, Comma:=False, Space _ ' :=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _ ' Array(3, 1), Array(4, 1), Array(5, 1)) Range("A1").Select Selection.EntireRow.Insert Range("B1").Select Selection.EntireColumn.Insert Columns("B:B").ColumnWidth = 17.86 Range("A2").End(xlDown).Select LastRowA = Selection.Address ActiveCell.Offset(, columnOffset:=1).Activate LastRowB = Selection.Address ActiveCell.Offset(, columnOffset:=1).Activate LastRowC = Selection.Address ActiveCell.Offset(, columnOffset:=2).Activate LastRowE = Selection.Address Range("A1").Select ActiveCell.FormulaR1C1 = "T" Range("A2", LastRowA).Name = "T" Range("B1").Select ActiveCell.FormulaR1C1 = "HOUR" Range("B2").Select ActiveCell.FormulaR1C1 = "=SUM(T/36000)" Range("B2", LastRowB).Select Selection.FillDown Range("B2", LastRowB).Select Selection.NumberFormat = "0.0" Range("B2", LastRowB).Name = "HOUR" Range("C1").Select ActiveCell.FormulaR1C1 = "SIGNAL COUNT" Range("C2").Select Columns("C:C").ColumnWidth = 16.57 Range("C2", LastRowC).Name = "SIGNAL_COUNT" Columns("D:D").Select Selection.Insert Shift:=xlToRight Columns("F:F").Select Selection.Cut Columns("D:D").Select ActiveSheet.Paste Selection.ColumnWidth = 17 Range("D1").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "I POLL INTERVAL" Range("E1").Select Columns("E:E").ColumnWidth = 25 Range("E1").Select ActiveCell.FormulaR1C1 = "PERSISTANCE" Range("A1:E1").Select With Selection .HorizontalAlignment = xlCenter End With ' Import the High Poll Class numbers ' Use this Open when the data has been prepared by Steve Barrett's process Workbooks.OpenText Filename:= _ VaxFile3ImportOpen, Origin:= _ xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _ Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _ Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _ Array(9, 1)) ' Use this Open when the data has been prepared by Rick Struble's DCL .com procedure ' Workbooks.OpenText Filename:= _ ' VaxFile3ImportOpen, Origin:= _ ' xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ ' Array(0, 1) Range("A1:I2").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("Poll Class 2 Worksheet").Select Range("M1").Select ActiveSheet.Paste ' this is to clear the clipboard: Range("Z2").Select Selection.Copy ' Done with this data file, close it Windows(VaxFile3Import).Activate ActiveWindow.Close ' Parse High Poll Class numbers Sheets("Poll Class 2 Worksheet").Select Range("M1:M2").Select Application.CutCopyMode = False ' Selection.TextToColumns Destination:=Range("M1"), DataType:= _ ' xlFixedWidth, FieldInfo:=Array(Array(0, 3), Array(9, 1), Array(18, 1), _ ' Array(24, 1), Array(32, 1)) Selection.NumberFormat = "mmmm d, yyyy" Columns("M:M").ColumnWidth = 20# Range("P1:Q2").Select Selection.NumberFormat = "#,##0" Range("M1").Select Let PC2HiDate = ActiveCell.Text Range("N1").Select Let PC2HiTime = ActiveCell.Text Range("P1").Select Let PC2HiValue = ActiveCell.Text Range("M2").Select Let PC3HiDate = ActiveCell.Text Range("N2").Select Let PC3HiTime = ActiveCell.Text Range("Q2").Select Let PC3HiValue = ActiveCell.Text Range("B2").Select PC2BegDate = Selection.Value PC2EndDate = PC2BegDate + 1 End Sub Sub Mod6Sub5_CreatePC2Graph() Range("C1", LastRowE).Select Sheets("Poll Class 2 Graph").Select ActiveSheet.ChartObjects.Add(5.25, 66, 614, 395).Select Application.CutCopyMode = False ActiveChart.ChartWizard Source:=Sheets("Poll Class 2 Worksheet").Range _ ("B1", LastRowE), Gallery:=xlXYScatter, Format:=2, PlotBy:= _ xlColumns, CategoryLabels:=1, SeriesLabels:=1, HasLegend:=1, _ Title:="", CategoryTitle:="", ValueTitle:="", ExtraTitle:="" ActiveSheet.DrawingObjects("Chart 1").Select Selection.Border.LineStyle = xlNone ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Position = xlBottom Selection.Left = 193 ActiveChart.Axes(xlCategory).Select With Selection.TickLabels.Font .Name = "Arial" .FontStyle = "Regular" .Size = 10 End With ActiveChart.Legend.Select With Selection.Font .Name = "Arial" .FontStyle = "Regular" .Size = 10 End With ActiveChart.PlotArea.Select Selection.Interior.ColorIndex = 2 Selection.Width = 582 ActiveChart.Axes(xlValue).Select With ActiveChart.Axes(xlValue) .MinimumScaleIsAuto = True .MaximumScale = 40 End With ActiveChart.SeriesCollection(3).Select ActiveChart.SeriesCollection(3).AxisGroup = 2 ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select ActiveChart.Legend.LegendEntries(1).LegendKey.Select With Selection.Border .Weight = xlThin .LineStyle = xlAutomatic End With With Selection .MarkerBackgroundColorIndex = 2 .MarkerForegroundColorIndex = 25 .MarkerStyle = xlSquare .Smooth = False End With ActiveChart.Legend.LegendEntries(2).LegendKey.Select With Selection.Border .Weight = xlThin .LineStyle = xlAutomatic End With With Selection .MarkerBackgroundColorIndex = 1 .MarkerForegroundColorIndex = 1 .MarkerStyle = xlCircle .Smooth = False End With ActiveChart.Legend.LegendEntries(3).LegendKey.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With With Selection .MarkerBackgroundColorIndex = 1 .MarkerForegroundColorIndex = 1 .MarkerStyle = xlSquare .Smooth = False End With ActiveChart.SeriesCollection(3).Select ' ActiveChart.SeriesCollection(3).Points(186).Select ActiveChart.Deselect ActiveChart.PlotArea.Select ActiveChart.SeriesCollection(3).Select With Selection.Border .ColorIndex = 1 .Weight = xlHairline .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 1 .MarkerForegroundColorIndex = 1 .MarkerStyle = xlSquare .Smooth = False End With ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlValue, xlSecondary).Select With ActiveChart.Axes(xlValue, xlSecondary) .MinimumScale = 0 .MaximumScaleIsAuto = True .MinorUnitIsAuto = True .MajorUnitIsAuto = True .Crosses = xlAutomatic .ReversePlotOrder = False .ScaleType = False End With ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlCategory).Select With ActiveChart.Axes(xlCategory) .MinimumScale = PC2BegDate .MaximumScale = PC2EndDate .MinorUnitIsAuto = True .MajorUnitIsAuto = True .Crosses = xlAutomatic .ReversePlotOrder = False .ScaleType = xlLinear End With ' Remove chart border ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select With Selection.Border .Weight = 1 .LineStyle = 0 End With ActiveChart.Deselect ActiveWindow.Visible = False ' Poll Class 2 Text 2 Box (Header) PC2DT = PC2HiDate + " " + PC2HiTime + " GMT" HeaderPC2 = "SIGNAL COUNT -VS- TIME SYSTEM " + SysNum + " " + PC2DT ActiveSheet.TextBoxes.Add(3, 1.5, 617.25, 21.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = HeaderPC2 With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 2").Select Selection.Border.LineStyle = xlNone ' Text 3 Box ActiveSheet.TextBoxes.Add(3, 47, 617.25, 21.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "POLL CLASS 2" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 3").Select Selection.Border.LineStyle = xlNone Range("A1").Select ActiveSheet.TextBoxes.Add(0, 135.75, 16.5, 260).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "SIGNAL COUNT" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With Selection.HorizontalAlignment = xlCenter Selection.VerticalAlignment = xlCenter Selection.Orientation = xlVertical Selection.AutoSize = False Selection.Border.LineStyle = xlNone ActiveSheet.TextBoxes.Add(5.25, 512.25, 615, 20.25).Select Selection.Interior.ColorIndex = 2 ActiveWindow.LargeScroll ToRight:=-1 Selection.Characters.Text = "Qualcomm Proprietary" With Selection.Characters(Start:=1, Length:=20).Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter Selection.Border.LineStyle = xlNone ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.SeriesCollection(3).Select With Selection.Border .ColorIndex = 1 .Weight = xlHairline .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 3 .MarkerForegroundColorIndex = 3 .MarkerStyle = xlSquare End With ActiveWindow.Visible = False ActiveSheet.TextBoxes.Add(600, 195, 15, 151).Select Selection.Characters.Text = "PERSISTANCE" With Selection.Characters(Start:=1, Length:=11).Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With Selection.Border.LineStyle = xlNone With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Orientation = xlVertical End With ActiveSheet.TextBoxes.Add(227, 478, 184, 17.25).Select ' Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "B+ 40 RLRs 20 CHANNELS" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With Selection.HorizontalAlignment = xlCenter Selection.Border.LineStyle = xlNone Selection.Height = 12 ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Left = 151 Selection.Top = 386 Selection.Height = 16 Selection.Top = 387 ActiveWindow.Visible = False ActiveSheet.DrawingObjects("Text 5").Select Selection.Top = 510.75 Selection.Height = 21.75 Selection.Left = 7.5 Selection.Top = 520.5 ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Left = 150 ActiveChart.Deselect ActiveWindow.Visible = False ActiveSheet.Lines.Add(33, 288, 541, 262).Select ActiveSheet.DrawingObjects("Line 8").Select With Selection.Border .LineStyle = xlDashDot .ColorIndex = 1 .Weight = xlMedium End With With Selection .ArrowHeadStyle = xlNone .ArrowHeadWidth = xlMedium .ArrowHeadLength = xlMedium End With ActiveSheet.DrawingObjects("Line 8").Select Selection.Height = -15.75 Selection.Width = 541.5 Selection.Height = -1.5 ActiveSheet.DrawingObjects("Text 6").Select Selection.Left = 606 ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Left = 110 Selection.Width = 345 Selection.Width = 365 ActiveChart.Deselect ActiveWindow.Visible = False ActiveSheet.DrawingObjects("Text 7").Select Selection.Top = 463.5 ActiveSheet.TextBoxes.Add(509, 445, 77, 12.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = PC2HiValue + " SIGNALS" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Regular" .Size = 8 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 9").Select Selection.Border.LineStyle = xlNone ActiveSheet.DrawingObjects("Line 8").Select Selection.Width = 525 Range("A1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlValue, xlSecondary).Select With ActiveChart.Axes(xlValue, xlSecondary) .MinimumScale = 0 .MaximumScale = 1 End With Range("A1").Select ActiveWindow.LargeScroll Down:=-2 Range("A1").Select End Sub Sub Mod6Sub6_ImportAndPrepPC3Data() ' This sub opens the relevant data file, copies the data to the worksheet, ' then parses and preps the data as needed. Workbooks.OpenText Filename:= _ VaxFile2ImportOpen, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) Windows(VaxFile2Import).Activate Columns("A:A").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("Poll Class 3 text orig").Select Range("A1").Select ActiveSheet.Paste ActiveWindow.SelectedSheets.Visible = False Sheets("Poll Class 3 Worksheet").Select Range("A1").Select ActiveSheet.Paste ' this is to clear the clipboard: Range("Z1").Select Selection.Copy Windows(VaxFile2Import).Activate ActiveWindow.Close ' Parse Poll Class 3 ' Sheets("Poll Class 3 Worksheet").Select Columns("A:A").Select Application.CutCopyMode = False ' use this TextToColumns when data is prepared by Steve Barrett's process Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)) ' Use this TextToColumns when data is prepared by DCL .com procedure ' Selection.TextToColumns Destination:=Range("A1"), DataType:= _ ' xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _ ' :=True, Tab:=True, Semicolon:=False, Comma:=False, Space:= _ ' True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array _ ' (3, 1), Array(4, 1)) Rows("1:1").Select Selection.Insert Shift:=xlDown Columns("C:C").Select Selection.Insert Shift:=xlToRight Selection.Insert Shift:=xlToRight Columns("B:B").Select Selection.Insert Shift:=xlToRight Columns("G:G").Select Selection.Cut Columns("D:D").Select ActiveSheet.Paste Columns("E:E").Select Selection.Delete Shift:=xlToLeft Range("A2").End(xlDown).Select LastRowA = Selection.Address ActiveCell.Offset(, columnOffset:=1).Activate LastRowB = Selection.Address ActiveCell.Offset(, columnOffset:=1).Activate LastRowC = Selection.Address ActiveCell.Offset(, columnOffset:=2).Activate LastRowE = Selection.Address Range("A1").Select ActiveCell.FormulaR1C1 = "S" Range("A2", LastRowA).Name = "S" Range("B1").Select ActiveCell.FormulaR1C1 = "HOUR3" Range("B2").Select ActiveCell.FormulaR1C1 = "=SUM(S/36000)" Columns("B:B").Select Selection.NumberFormat = "0.0" Range("B2", LastRowB).Select Selection.FillDown Range("B2", LastRowB).Name = "HOUR3" Range("C1").Select ActiveCell.FormulaR1C1 = "SIGNAL COUNT" Range("C2").Select Columns("C:C").ColumnWidth = 18.57 Range("C2", LastRowC).Name = "SIGNAL_COUNT" Range("D1").Select ActiveCell.FormulaR1C1 = "I POLL INTERVAL" Range("D2").Select Columns("D:D").ColumnWidth = 18.86 Range("E1").Select ActiveCell.FormulaR1C1 = "PERSISTENCE" Range("E2").Select Columns("E:E").ColumnWidth = 17 Range("A1:E1").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = xlHorizontal End With Range("B2").Select PC3BegDate = Selection.Value PC3EndDate = PC3BegDate + 1 End Sub Sub Mod6Sub7_CreatePC3Graph() ' Create Poll Class 3 Graph Range("B1", LastRowE).Select Sheets("Poll Class 3 Graph").Select ActiveSheet.ChartObjects.Add(5.25, 66, 614, 395).Select Application.CutCopyMode = False ActiveChart.ChartWizard Source:=Sheets("Poll Class 3 Worksheet").Range _ ("B1", LastRowE), Gallery:=xlXYScatter, Format:=2, PlotBy:= _ xlColumns, CategoryLabels:=1, SeriesLabels:=1, HasLegend:=1, _ Title:="", CategoryTitle:="", ValueTitle:="", ExtraTitle:="" ActiveSheet.DrawingObjects("Chart 1").Select Selection.Border.LineStyle = xlNone ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Position = xlBottom Selection.Left = 193 ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.SeriesCollection(3).Select ActiveChart.SeriesCollection(3).AxisGroup = 2 ActiveChart.Axes(xlValue, xlSecondary).Select With ActiveChart.Axes(xlValue, xlSecondary) .MinimumScale = 0 End With ActiveChart.Axes(xlCategory).Select With Selection.TickLabels.Font .Name = "Arial" .FontStyle = "Regular" .Size = 10 End With ActiveChart.Legend.Select With Selection.Font .Name = "Arial" .FontStyle = "Regular" .Size = 10 End With ActiveChart.PlotArea.Select Selection.Interior.ColorIndex = 2 Selection.Width = 582 ActiveChart.Axes(xlValue).Select With ActiveChart.Axes(xlValue) .MinimumScaleIsAuto = True .MaximumScale = 50 End With ActiveChart.SeriesCollection(3).Select ActiveChart.SeriesCollection(3).AxisGroup = 2 ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select ActiveChart.Legend.LegendEntries(1).LegendKey.Select With Selection.Border .Weight = xlThin .LineStyle = xlAutomatic End With With Selection .MarkerBackgroundColorIndex = 2 .MarkerForegroundColorIndex = 25 .MarkerStyle = xlSquare .Smooth = False End With ActiveChart.Legend.LegendEntries(2).LegendKey.Select With Selection.Border .Weight = xlThin .LineStyle = xlAutomatic End With With Selection .MarkerBackgroundColorIndex = 1 .MarkerForegroundColorIndex = 1 .MarkerStyle = xlCircle .Smooth = False End With ActiveChart.Legend.LegendEntries(3).LegendKey.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With With Selection .MarkerBackgroundColorIndex = 1 .MarkerForegroundColorIndex = 1 .MarkerStyle = xlSquare .Smooth = False End With ActiveChart.SeriesCollection(3).Select ActiveChart.SeriesCollection(3).Points(186).Select ActiveChart.Deselect ActiveChart.PlotArea.Select ActiveChart.SeriesCollection(3).Select With Selection.Border .ColorIndex = 1 .Weight = xlHairline .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 1 .MarkerForegroundColorIndex = 1 .MarkerStyle = xlSquare .Smooth = False End With ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlValue, xlSecondary).Select With ActiveChart.Axes(xlValue, xlSecondary) .MinimumScale = 0 .MaximumScaleIsAuto = True .MinorUnitIsAuto = True .MajorUnitIsAuto = True .Crosses = xlAutomatic .ReversePlotOrder = False .ScaleType = False End With ActiveChart.Deselect ActiveWindow.Visible = False ' Poll Class 3 Text 2 Box (Header) PC3DT = PC3HiDate + " " + PC3HiTime + " GMT" HeaderPC3 = "SIGNAL COUNT -VS- TIME SYSTEM " + SysNum + " " + PC3DT ActiveSheet.TextBoxes.Add(3, 1.5, 617.25, 21.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = HeaderPC3 With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 2").Select Selection.Border.LineStyle = xlNone ' Text 3 Box ActiveSheet.TextBoxes.Add(3, 47, 617.25, 21.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "POLL CLASS 3" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 3").Select Selection.Border.LineStyle = xlNone Range("A1").Select ActiveSheet.TextBoxes.Add(0, 135.75, 16.5, 260).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = "SIGNAL COUNT" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With Selection.HorizontalAlignment = xlCenter Selection.VerticalAlignment = xlCenter Selection.Orientation = xlVertical Selection.AutoSize = False Selection.Border.LineStyle = xlNone ActiveSheet.TextBoxes.Add(5.25, 512.25, 615, 20.25).Select Selection.Interior.ColorIndex = 2 ActiveWindow.LargeScroll ToRight:=-1 Selection.Characters.Text = "Qualcomm Proprietary" With Selection.Characters(Start:=1, Length:=20).Font .Name = "Arial" .FontStyle = "Bold" .Size = 12 End With Selection.HorizontalAlignment = xlCenter Selection.Border.LineStyle = xlNone ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.SeriesCollection(3).Select With Selection.Border .ColorIndex = 1 .Weight = xlHairline .LineStyle = xlContinuous End With With Selection .MarkerBackgroundColorIndex = 3 .MarkerForegroundColorIndex = 3 .MarkerStyle = xlSquare End With ActiveWindow.Visible = False ActiveSheet.TextBoxes.Add(600, 195, 15, 151).Select Selection.Characters.Text = "PERSISTANCE" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With Selection.Border.LineStyle = xlNone With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Orientation = xlVertical End With ActiveSheet.TextBoxes.Add(227, 478, 184, 17.25).Select Selection.Characters.Text = "B+ 40 RLRs 34 CHANNELS 3Xs DATA RATE" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With Selection.HorizontalAlignment = xlCenter Selection.Border.LineStyle = xlNone Selection.Height = 12 ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Left = 151 Selection.Top = 386 Selection.Height = 16 Selection.Top = 387 ActiveWindow.Visible = False ActiveSheet.DrawingObjects("Text 5").Select Selection.Top = 510.75 Selection.Height = 21.75 Selection.Left = 7.5 Selection.Top = 520.5 ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Left = 150 ActiveChart.Deselect ActiveWindow.Visible = False ActiveSheet.Lines.Add(33, 288, 541.5, 203).Select ActiveSheet.DrawingObjects("Line 8").Select With Selection.Border .LineStyle = xlDashDot .ColorIndex = 1 .Weight = xlMedium End With With Selection .ArrowHeadStyle = xlNone .ArrowHeadWidth = xlMedium .ArrowHeadLength = xlMedium End With ActiveSheet.DrawingObjects("Line 8").Select Selection.Height = -15.75 Selection.Height = -1.5 ActiveSheet.DrawingObjects("Text 6").Select Selection.Left = 606 ActiveSheet.DrawingObjects("Chart 1").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select Selection.Left = 110 Selection.Width = 345 Selection.Width = 365 ActiveChart.Deselect ActiveWindow.Visible = False ActiveSheet.DrawingObjects("Text 7").Select Selection.Top = 463.5 ActiveSheet.TextBoxes.Add(509, 445, 77, 12.75).Select Selection.Interior.ColorIndex = 2 Selection.Characters.Text = PC3HiValue + " SIGNALS" With Selection.Characters.Font .Name = "Arial" .FontStyle = "Regular" .Size = 8 End With Selection.HorizontalAlignment = xlCenter ActiveSheet.DrawingObjects("Text 9").Select Selection.Border.LineStyle = xlNone ActiveSheet.DrawingObjects("Line 8").Select Selection.Width = 525 ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlCategory).Select With ActiveChart.Axes(xlCategory) .MinimumScale = PC3BegDate .MaximumScale = PC3EndDate .MinorUnitIsAuto = True .MajorUnitIsAuto = True .Crosses = xlAutomatic .ReversePlotOrder = False .ScaleType = xlLinear End With ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Axes(xlValue, xlSecondary).Select With ActiveChart.Axes(xlValue, xlSecondary) .MinimumScale = 0 .MaximumScale = 1 End With ' Remove chart border ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select With Selection.Border .Weight = 1 .LineStyle = 0 End With Range("A1").Select End Sub Sub Mod6Sub8_ImportDataAndFillRlrForm() ' This sub opens the relevant data file and copies the data to the RLR summary worksheet. 'get the dates here Workbooks.Add Columns("A:A").ColumnWidth = 45 Columns("B:B").ColumnWidth = 30 Range("A7").Select ActiveCell.FormulaR1C1 = EndDay Range("A6").Select ActiveCell.FormulaR1C1 = "=R[1]C-1" Range("A1:A6").Select Range("A6").Activate Selection.FillUp Range("A1").Select Selection.Copy Range("B1").Select ActiveSheet.Paste Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "=RC[-1]" Range("B1").Select Selection.NumberFormat = "mmm d" Range("A1:A7").Select Selection.NumberFormat = "mmm d, yyyy" Range("A1").Select Let MonDate = ActiveCell.Text Range("A2").Select Let TueDate = ActiveCell.Text Range("A3").Select Let WedDate = ActiveCell.Text Range("A4").Select Let ThuDate = ActiveCell.Text Range("A5").Select Let FriDate = ActiveCell.Text Range("A6").Select Let SatDate = ActiveCell.Text Range("A7").Select Let SunDate = ActiveCell.Text Range("B1").Select Let MonDay = ActiveCell.Text ActiveWorkbook.Saved = True ActiveWindow.Close ' copy the data to the form here Workbooks.OpenText Filename:= _ VaxFile4ImportOpen, Origin:=xlWindows, _ StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon _ :=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(Array(1, 2), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _ Array(6, 1)) Windows(VaxFile4Import).Activate Range("B3:C26").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("RLR Summary").Select Range("C5").Select Selection.PasteSpecial Paste:=xlValues Windows(VaxFile4Import).Activate Range("D3:E26").Select Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("RLR Summary").Select Range("F5").Select Selection.PasteSpecial Paste:=xlValues Windows(VaxFile4Import).Activate Range("F3:G26").Select Application.CutCopyMode = False Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("RLR Summary").Select Range("I5").Select Selection.PasteSpecial Paste:=xlValues Windows(VaxFile4Import).Activate Range("H3:I26").Select Application.CutCopyMode = False Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("RLR Summary").Select Range("L5").Select Selection.PasteSpecial Paste:=xlValues Windows(VaxFile4Import).Activate Range("J3:K26").Select Application.CutCopyMode = False Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("RLR Summary").Select Range("O5").Select Selection.PasteSpecial Paste:=xlValues Windows(VaxFile4Import).Activate Range("L3:M26").Select Application.CutCopyMode = False Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("RLR Summary").Select Range("R5").Select Selection.PasteSpecial Paste:=xlValues Windows(VaxFile4Import).Activate Range("N3:O26").Select Application.CutCopyMode = False Selection.Copy Windows(GraphsAndWorksheets).Activate Sheets("RLR Summary").Select Range("U5").Select Selection.PasteSpecial Paste:=xlValues ' Add Dates for each day here ActiveSheet.DrawingObjects("Text 1").Select Selection.Characters.Text = MonDate ActiveSheet.DrawingObjects("Text 2").Select Selection.Characters.Text = TueDate ActiveSheet.DrawingObjects("Text 3").Select Selection.Characters.Text = WedDate ActiveSheet.DrawingObjects("Text 4").Select Selection.Characters.Text = ThuDate ActiveSheet.DrawingObjects("Text 5").Select Selection.Characters.Text = FriDate ActiveSheet.DrawingObjects("Text 6").Select Selection.Characters.Text = SatDate ActiveSheet.DrawingObjects("Text 7").Select Selection.Characters.Text = SunDate HeaderText = "RLR Summary SYSTEM " + SysNum + " " + MonDay + " through " + SunDate ActiveSheet.DrawingObjects("Text 8").Select Selection.Characters.Text = HeaderText Windows(VaxFile4Import).Activate ActiveWindow.Close ' Highlight the high Poll Class Numbers Windows(GraphsAndWorksheets).Activate With Worksheets("RLR Summary").Range("PC2_Range") Set c = .Find(PC2HiValue, LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do 'c.Interior.Pattern = xlPatternGray25 c.Interior.ColorIndex = 6 Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With With Worksheets("RLR Summary").Range("PC3_Range") Set c = .Find(PC3HiValue, LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do 'c.Interior.Pattern = xlPatternGray25 c.Interior.ColorIndex = 6 Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With End Sub Sub Mod6Sub9_SizePositionGraph() ' Size and position the worksheet on the screen (stagger windows) If LapTopFlag = 0 Then TopWindow = SysNum * 15 LeftWindow = 520 + (SysNum * 14) With ActiveWindow .Width = 200 .Height = 100 .Top = TopWindow .Left = LeftWindow End With Else 'If using laptop, different window sizes and locations TopWindow = SysNum * 14 LeftWindow = 380 + (SysNum * 7) With ActiveWindow .Width = 150 .Height = 90 .Top = TopWindow .Left = LeftWindow End With End If ActiveWorkbook.Save End Sub Sub Mod6Subb10_CleanUp() ' Deselect Poll Class Graph objects Windows(GraphsAndWorksheets).Activate Sheets("Poll Class 3 Worksheet").Select Range("A1").Select Sheets("Poll Class 2 Worksheet").Select Range("A1").Select Sheets("RLR Summary").Select Range("A1").Select Sheets("Poll Class 3 Graph").Select Range("A1").Select Sheets("Poll Class 2 Graph").Select ActiveWindow.LargeScroll Down:=-1 Range("A1").Select End Sub =============== Private ExitFlag As Integer Private HtmlFile As String Private WeeklyFile As String Private FlpFile As String Private PollFile As String Private TempGifName As Variant Private TempGifNum As Variant Sub Mod7Sub1_HtmlConversionMacro() ' This module makes 2 copies of each system graph, inserts them into a separate Excel ' worksheet, sizes them for the Omni intranet web site, and makes any changes to the ' graphs necessary before converting them to HTML (.gif) format and putting them on the web. Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules Mod7Sub2_CheckFlags If ExitFlag = 1 Then Exit Sub For Graphs = LoopFrom To LoopTo Mod7Sub3_Init Mod7Sub4_Convert_Weekly Mod7Sub5_Convert_Daily Mod7Sub6_Convert_Bars Mod7Sub7_Convert_FLP Mod7Sub8_Convert_RLP Mod7Sub9_Convert_PC2 Mod7Subb10_Convert_PC3 Mod7Subb11_SizePositionGraph Mod7Subb12_CreateGifs Next Graphs Mod10Sub1_WriteWebDataFile Application.ScreenUpdating = True End Sub Sub Mod7Sub2_CheckFlags() ' This sub checks various flags. If they're set it then sets the ExitFlag so this module ' will not run. It also sets the loop variable using info the user input at the menu, ' or if running in batch, it sets the loop to graph for all systems. If MenuFlag = 1 Then If HtmlFlag = 0 Then ExitFlag = 1 If DailyFlag = 1 Then ExitFlag = 1 If WeekFrom = 0 Then ExitFlag = 1 'LoopFrom = HtmlFrom 'LoopTo = HtmlTo LoopFrom = WeekFrom LoopTo = WeekTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If End Sub Sub Mod7Sub3_Init() ' This sub defines the file name variables. Each time through the loop, the file names ' change, in order to do each Omni system. SysNum is the variable doing this. SysNum = Graphs HtmlFile = EndWeek + "_Sys" + SysNum + ".xls" WeeklyFile = M3_Workbook + SysNum + " Week of " + StartDay + ".xls" FlpFile = M5_Workbook1 + SysNum + " Week of " + StartDay + ".xls" PollFile = M6_Workbook + SysNum + " Week of " + StartDay + ".xls" Workbooks.Open Filename:=TemplateLocation + M7_Template ActiveWorkbook.SaveAs Filename:= _ HtmlLocation + HtmlFile End Sub Sub Mod7Sub4_Convert_Weekly() Windows(HtmlFile).Activate With ActiveWindow .Top = 246.25 .Left = 111.25 End With Windows(WeeklyFile).Activate ' Copy Weekly Graph Windows(WeeklyFile).Activate Sheets("Weekly Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select Selection.Copy ' Paste Weekly Graph / large size Windows(HtmlFile).Activate Sheets("Large Weekly").Select Range("A1").Select ActiveSheet.Paste ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.88, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.97, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 0.99, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveChart.Shapes("Text 1").Select Selection.Cut ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' Copy Weekly Graph Windows(WeeklyFile).Activate Sheets("Weekly Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select Selection.Copy ' Paste Weekly Graph / small size Windows(HtmlFile).Activate Sheets("Small Weekly").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate Windows(HtmlFile).SmallScroll Down:=4 ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.82, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.49, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1.01, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft Windows(HtmlFile).LargeScroll Down:=-1 ' Strip out items not needed for Web version ActiveChart.Shapes("Text 1").Select Selection.Cut ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ActiveWindow.Visible = False ActiveWindow.WindowState = xlNormal End Sub Sub Mod7Sub5_Convert_Daily() ' copy Daily Graph Windows(WeeklyFile).Activate Sheets("Daily Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ActiveSheet.ChartObjects("Chart 1").Activate ' Paste Daily Graph / large size Windows(HtmlFile).Activate Sheets("Large Daily").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.88, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.97, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 0.99, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.04, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveChart.Shapes("Text 1").Select Selection.Cut ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' Copy Daily Graph Windows(WeeklyFile).Activate Sheets("Daily Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste Daily Graph / small size Windows(HtmlFile).Activate Sheets("Small Daily").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.82, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.03, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveChart.Shapes("Text 1").Select Selection.Cut ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ActiveWindow.WindowState = xlNormal End Sub Sub Mod7Sub6_Convert_Bars() ' Copy 1st Bar Chart Graph (Peak Traffic Packets) Windows(WeeklyFile).Activate Sheets("Barchart Graph").Select ActiveSheet.ChartObjects("Chart 12").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste 1st Bar Chart Graph (Peak Traffic Packets) / large size Windows(HtmlFile).Activate Sheets("Large Bar 1").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.82, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.99, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1#, msoFalse, msoScaleFromTopLeft ' Copy 1st Bar Chart Graph (Peak Traffic Packets) Windows(WeeklyFile).Activate Sheets("Barchart Graph").Select ActiveSheet.ChartObjects("Chart 12").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste 1st Bar Chart Graph (Peak Traffic Packets) / small size Windows(HtmlFile).Activate Sheets("Small Bar 1").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.77, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.52, msoFalse, msoScaleFromTopLeft ActiveWindow.WindowState = xlNormal ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1#, msoFalse, msoScaleFromTopLeft ' Copy 2nd Bar Chart Graph (Peak Traffic Bits) Windows(WeeklyFile).Activate Sheets("Barchart Graph2").Select ActiveWorkbook.Saved = True ActiveSheet.ChartObjects("Chart 9").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ' Paste 2nd Bar Chart Graph (Peak Traffic Bits) / large size Windows(HtmlFile).Activate Sheets("Large Bar 2").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.82, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1#, msoFalse, msoScaleFromTopLeft ' Copy 2nd Bar Chart Graph (Peak Traffic Bits) Windows(WeeklyFile).Activate Sheets("Barchart Graph2").Select ActiveSheet.ChartObjects("Chart 9").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ' Paste 2nd Bar Chart Graph (Peak Traffic Bits) / small size Windows(HtmlFile).Activate Sheets("Small Bar 2").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.77, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.51, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveWindow.WindowState = xlNormal End Sub Sub Mod7Sub7_Convert_FLP() ' Copy FLP Graph Windows(FlpFile).Activate Sheets("FLP Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste FLP Graph / large size Windows(HtmlFile).Activate Sheets("Large FLP").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.96, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.07, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' Copy FLP Graph Windows(FlpFile).Activate Sheets("FLP Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste FLP Graph / small size Windows(HtmlFile).Activate Sheets("Small FLP").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.91, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.54, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ActiveWindow.WindowState = xlNormal End Sub Sub Mod7Sub8_Convert_RLP() ' Copy RLP Graph Windows(FlpFile).Activate Sheets("RLP Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste RLP Graph / large size Windows(HtmlFile).Activate Sheets("Large RLP").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.96, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.07, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' Copy RLP Graph Windows(FlpFile).Activate Sheets("RLP Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste RLP Graph / small size Windows(HtmlFile).Activate Sheets("Small RLP").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.91, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.54, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ActiveWindow.ScrollWorkbookTabs Position:=xlLast ActiveWindow.WindowState = xlNormal End Sub Sub Mod7Sub9_Convert_PC2() ' Copy Poll Class 2 Graph Windows(PollFile).Activate Sheets("Poll Class 2 Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste Poll Class 2 Graph / large size Windows(HtmlFile).Activate Sheets("Large PC2").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.88, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.1, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1#, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' Copy Poll Class 2 Graph Windows(PollFile).Activate Sheets("Poll Class 2 Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste Poll Class 2 Graph / small size Windows(HtmlFile).Activate Sheets("Small PC2").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.83, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.56, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ActiveWindow.WindowState = xlNormal End Sub Sub Mod7Subb10_Convert_PC3() ' Copy Poll Class 3 Graph Windows(PollFile).Activate Sheets("Poll Class 3 Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ' ActiveWindow.Visible = False ActiveWindow.WindowState = xlNormal ' Paste Poll Class 3 Graph / large size Windows(HtmlFile).Activate ActiveWindow.WindowState = xlMaximized Sheets("Large PC3").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.88, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.1, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1#, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' Copy Poll Class 3 Graph Windows(PollFile).Activate Sheets("Poll Class 3 Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste Poll Class 3 Graph / small size Windows(HtmlFile).Activate Sheets("Small PC3").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.83, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.56, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleWidth 1#, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' ActiveWindow.Visible = False ActiveWindow.ScrollWorkbookTabs Position:=xlFirst End Sub Sub Mod7Subb11_SizePositionGraph() ' Size and position the worksheet on the screen (stagger windows) Windows(HtmlFile).Activate If LapTopFlag = 0 Then TopWindow = 230 + (SysNum * 15) LeftWindow = 15 + (SysNum * 14) With ActiveWindow .Width = 200 .Height = 100 .Top = TopWindow .Left = LeftWindow End With Else ' If using laptop, window sizes and locations are different TopWindow = 200 + (SysNum * 14) LeftWindow = 15 + (SysNum * 7) With ActiveWindow .Width = 150 .Height = 90 .Top = TopWindow .Left = LeftWindow End With End If ActiveWorkbook.Save End Sub Sub Mod7Subb12_CreateGifs() Windows(HtmlFile).Activate ' Large Weekly Sheets("Large Weekly").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "1.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Large Daily Sheets("Large Daily").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "2.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Large FLP Sheets("Large FLP").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "3.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Large RLP Sheets("Large RLP").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "4.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Large PC2 Sheets("Large PC2").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "5.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Large PC3 Sheets("Large PC3").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "6.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Large Bar 1 Sheets("Large Bar 1").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "7.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Large Bar 2 Sheets("Large Bar 2").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "8.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Small Weekly Sheets("Small Weekly").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "9.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Small Daily Sheets("Small Daily").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "10.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Small FLP Sheets("Small FLP").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "11.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Small RLP Sheets("Small RLP").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "12.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Small PC2 Sheets("Small PC2").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "13.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Small PC3 Sheets("Small PC3").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "14.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Small Bar 1 Sheets("Small Bar 1").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "15.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ' Small Bar 2 Sheets("Small Bar 2").Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "16.gif" TempGifName = "Y:\Public\Graphs\_Html\" + EndWeek + "_sys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" ActiveWindow.Visible = False Range("A1").Select ActiveWorkbook.Save End Sub ======== Private ExitFlag As Integer Private FlpFile As String Private HtmlFile As String Private LargeFlp As String Private SmallFlp As String Sub Mod9Sub1_HtmlConversionDailyFlp() ' This module makes 2 copies of each system FLP graph, inserts them into a separate Excel ' worksheet, sizes them for the Omni intranet web site, and makes any changes to the ' graphs necessary before converting them to HTML (.gif) format and putting them on the web. Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules Mod9Sub2_CheckFlags If ExitFlag = 1 Then Exit Sub For Graphs = LoopFrom To LoopTo Mod9Sub3_Init ' Mod9Sub4_AutoConvert_FLP ' use this when Bullfrog can do HTML conversion Mod9Sub5_Convert_FLP ' use this when still doing conversion by hand Mod9Sub6_CreateGifs Next Graphs Mod9Sub7_SizePositionGraph ' Copy the gifs to the web Shell "Y:\Public\Graphs\Batch\Daily_4.bat" Application.ScreenUpdating = True End Sub Sub Mod9Sub2_CheckFlags() ' This sub checks various flags. If they're set it then sets the ExitFlag so this module ' will not run. It also sets the loop variable. If DailyFlag = 0 Then ExitFlag = 1 LoopFrom = 1 LoopTo = TotalNumOfSys End Sub Sub Mod9Sub3_Init() ' This sub defines the file name variables. Each time through the loop, the file names ' change, in order to do each Omni system. SysNum is the variable doing this. SysNum = Graphs HtmlFile = "CurrentFlpGraphs.xls" ' HtmlFile = "CurrentFlpSys" + SysNum + ".xls" FlpFile = M5_Workbook2 + SysNum + " Week of " + StartDay + ".xls" LargeFlp = "LargeFlpSys" + SysNum SmallFlp = "SmallFlpSys" + SysNum If Graphs = 1 Then Workbooks.Open Filename:=TemplateLocation + m9_Template ActiveWorkbook.SaveAs Filename:= _ DailyFlpLocation + HtmlFile End If End Sub Sub Mod9Sub4_AutoConvert_FLP() ' Copy FLP Graph Windows(FlpFile).Activate Sheets("FLP Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste FLP Graph / large size Windows(HtmlFile).Activate Sheets("Large FLP").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.96, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.07, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' Copy FLP Graph Windows(FlpFile).Activate Sheets("FLP Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste FLP Graph / small size Windows(HtmlFile).Activate Sheets("Small FLP").Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.91, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.54, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ActiveWindow.WindowState = xlNormal End Sub Sub Mod9Sub5_Convert_FLP() ' Copy FLP Graph Windows(FlpFile).Activate Sheets("FLP Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste FLP Graph / large size Windows(HtmlFile).Activate Sheets(LargeFlp).Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.96, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.07, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ' Copy FLP Graph Windows(FlpFile).Activate Sheets("FLP Graph").Select ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy ActiveWindow.WindowState = xlNormal ' Paste FLP Graph / small size Windows(HtmlFile).Activate Sheets(SmallFlp).Select Range("A1").Select ActiveSheet.Paste ActiveSheet.ChartObjects("Chart 1").Activate ' Resize ActiveSheet.Shapes("Chart 1").ScaleWidth 0.91, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 0.54, msoFalse, msoScaleFromTopLeft ActiveSheet.Shapes("Chart 1").ScaleHeight 1.01, msoFalse, msoScaleFromTopLeft ' Strip out items not needed for Web version ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.Legend.Select With Selection.Border .Weight = xlHairline .LineStyle = xlNone End With ActiveWindow.WindowState = xlNormal End Sub Sub Mod9Sub6_CreateGifs() Windows(HtmlFile).Activate ' Large Flp Sheets(LargeFlp).Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "1.gif" TempGifName = "Y:\Public\Graphs\_DailyFlp\" + "CurrentFlpSys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" Range("A1").Select ' Small Flp Sheets(SmallFlp).Select ActiveSheet.ChartObjects("Chart 1").Activate TempGifNum = SysNum + "2.gif" TempGifName = "Y:\Public\Graphs\_DailyFlp\" + "CurrentFlpSys" + TempGifNum ActiveChart.Export Filename:=TempGifName, Filtername:="GIF" Range("A1").Select End Sub Sub Mod9Sub7_SizePositionGraph() ' Size and position the worksheet on the screen (stagger windows) Windows(HtmlFile).Activate Sheets(LargeFlp).Select If LapTopFlag = 0 Then TopWindow = 245 ' + (SysNum * 15) LeftWindow = 30 ' + (SysNum * 14) With ActiveWindow .Width = 200 .Height = 100 .Top = TopWindow .Left = LeftWindow End With Else ' If using laptop, window sizes and locations are different TopWindow = 215 ' + (SysNum * 14) LeftWindow = 22 ' + (SysNum * 7) With ActiveWindow .Width = 150 .Height = 90 .Top = TopWindow .Left = LeftWindow End With End If ActiveWorkbook.Save End Sub ================== Private ArrayVariable As Integer Private CompareDate As Integer Private CurrentDate As Integer Private DateVarText As String Private ExitFlag As Integer Private WriteDateLoop As Integer Dim DateText(1 To 12) As Variant Sub Mod10Sub1_WriteWebDataFile() ' This module is called from Mod__7_HtmlConversionMacro, and calculates the ' week ending dates for the last four weeks and for the last ' week of the month for the last 5 months. ' It then creates a data file of these dates (Data.Txt) and this is saved to ' the same directory as the HTML files. ' Mod10Sub2_CreateDateList Mod10Sub3_GetDates Mod10Sub4_WriteDataFile End Sub Sub Mod10Sub2_CreateDateList() WeekEndingDate = EndDay ' While testing, insert WeekEndingDate here: ' WeekEndingDate = "October 11, 1998" ' WeekEndingDate = "080998" Workbooks.Add Columns("A:E").ColumnWidth = 20 Range("A1:A31").Select Selection.NumberFormat = "mmddyy" ' Insert this week's ending date Range("A1").Select Selection.Characters.Text = WeekEndingDate ' Duplicate it with Excel's default format ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = "=R[-1]C-0" ' Add a list of the last 40 week ending dates For dateloop = 1 To 40 ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = "=R[-1]C-7" Next dateloop 'Copy list to column B and format for month Range("A1:A42").Select Application.CutCopyMode = False Selection.Copy Range("B1").Select ActiveSheet.Paste Range("B2:B42").Select Selection.NumberFormat = "mm" ' Copy list to column C and format for day Range("A1:A42").Select Application.CutCopyMode = False Selection.Copy Range("C1").Select ActiveSheet.Paste Range("C2:C42").Select Selection.NumberFormat = "dd" End Sub Sub Mod10Sub3_GetDates() ' Get the last 4 week ending dates Range("A2").Select For DateLoop2 = 1 To 4 DateText(DateLoop2) = ActiveCell.Text ActiveCell.Offset(1, 0).Select Next DateLoop2 ' Get the last week of the month's week ending date ' for the 5 months previous to the last four weeks Range("B5").Select Let CurrentDate = ActiveCell.Text ArrayVariable = 5 For DateLoop3 = 1 To 11 ActiveCell.Offset(1, 0).Select Let CompareDate = ActiveCell.Text If CompareDate <> CurrentDate Then ActiveCell.Offset(0, -1).Select DateText(ArrayVariable) = ActiveCell.Text ArrayVariable = ArrayVariable + 1 ActiveCell.Offset(0, 1).Select Let CurrentDate = ActiveCell.Text ActiveCell.Offset(3, 0).Select End If Next DateLoop3 ' Delete the columns not needed Columns("A:D").Select Selection.Delete Shift:=xlToLeft End Sub Sub Mod10Sub4_WriteDataFile() 'Create the Data.Txt file Range("A1").Select For WriteDateLoop = 1 To 9 Selection.Characters.Text = DateText(WriteDateLoop) ActiveCell.Offset(1, 0).Select Next WriteDateLoop ActiveWorkbook.Saved = True ' Create the actual data.txt file ActiveWorkbook.SaveAs Filename:= _ "Y:\Public\Graphs\_Html\Data.txt", FileFormat:=xlText, _ CreateBackup:=False ActiveWorkbook.Saved = True ActiveWindow.Close ' Copy the gifs to the web Shell "Y:\Public\Graphs\Batch\Weekly_4.bat" End Sub =============== Private EndDate As Integer Private EndDatePrev As Integer Private EndDateText As String Private EndDatePrevText As String Private MonthName1 As String Private MonthName1Prev As String Private MonthName2 As String Private MonthName2Prev As String Private StartDate As Integer Private StartDatePrev As Integer Private StartDateText As String Private StartDatePrevText As String Private TablesWorksheet As String Private TablesWorksheetPrev As String Private TablesWorksheetSave As String Private WeekEndingDate As String Private WeekEndingDatePrev As String Private YearName1 As Integer Private YearName1Prev As Integer Private YearName1Text As String Private YearName1PrevText As String Private YearName2 As Integer Private YearName2Prev As Integer Private YearName2Text As String Private YearName2PrevText As String Sub mod11Sub1_WklyRptTables() ' This subroutine asks for the weekending date for the ' tables the user wants to create. It then creates a new worksheet ' based on last week's table. It moves all last week's numbers to ' the last week columns and zeroes out this week's numbers, to ' be added manually now, and automatically at a later date. ' NOTE- Some nomenclature clarification: ' The most recent Tables data is always one week old. ' In the comments of this module, "this week's data/Tables" ' refers to that one week old data. "Last week's data/Tables" ' refers to the data/Tables from two weeks ago. Application.ScreenUpdating = False If TablesFlag = 0 Then Exit Sub mod12Sub1_TotalsMacro 'calculate the Weekly Totals first 'mod11Sub2_Init mod11Sub3_GetDates mod11Sub4_CreateWorksheet mod11Sub5_TransferData ' mod11Sub6_CleanUp Application.ScreenUpdating = True End Sub Sub mod11Sub2_Init() End Sub Sub mod11Sub3_GetDates() ' Uses the current date (as shown on the computer, so this must be set correctly) ' then automatically calculates last week's week-ending date. Workbooks.Add Columns("A:A").ColumnWidth = 20 Columns("B:B").ColumnWidth = 20 Range("A1").Select ActiveCell.FormulaR1C1 = "=NOW()" Selection.NumberFormat = "ddd" Let TempVar = ActiveCell.Text Range("A2").Select Select Case TempVar Case "Mon" ActiveCell.FormulaR1C1 = "=R[-1]C-1" Case "Tue" ActiveCell.FormulaR1C1 = "=R[-1]C-2" Case "Wed" ActiveCell.FormulaR1C1 = "=R[-1]C-3" Case "Thu" ActiveCell.FormulaR1C1 = "=R[-1]C-4" Case "Fri" ActiveCell.FormulaR1C1 = "=R[-1]C-5" Case "Sat" ActiveCell.FormulaR1C1 = "=R[-1]C-6" Case "Sun" ActiveCell.FormulaR1C1 = "=R[-1]C-7" End Select Range("A2").Select Selection.NumberFormat = "mm/dd/yy" WeekEndingDate = ActiveCell.Text ActiveWorkbook.Saved = True ActiveWindow.Close ' load date into menu Form_WklyRptTables.TextBox_WklyRptTables.Value = WeekEndingDate ' show the menu Form_WklyRptTables.Show ' reload date in case user changed it WeekEndingDate = Form_WklyRptTables.TextBox_WklyRptTables.Value ' Calculate the rest of the various date formats needed for ' starting a new set of Tables. Workbooks.Add Columns("A:C").ColumnWidth = 20 Range("A1:C8").Select Selection.NumberFormat = "mm/dd/yy" Range("C4").Select Selection.Characters.Text = WeekEndingDate Selection.Copy Range("A4").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Calculate start of the week Range("A1").Select ActiveCell.FormulaR1C1 = "=R[3]C-6" Selection.NumberFormat = "dd" StartDate = ActiveCell.Text Selection.NumberFormat = "mmm" MonthName1 = ActiveCell.Text Selection.NumberFormat = "yyyy" YearName1 = ActiveCell.Text ' Calculate end of the week Range("A2").Select ActiveCell.FormulaR1C1 = "=R[-1]C+6" Selection.NumberFormat = "dd" EndDate = ActiveCell.Text Selection.NumberFormat = "mmm" MonthName2 = ActiveCell.Text Selection.NumberFormat = "yyyy" YearName2 = ActiveCell.Text ' Calculate previous week Range("B4").Select ActiveCell.FormulaR1C1 = "=R[0]C[-1]-7" WeekEndingDatePrev = ActiveCell.Text ' Calculate start of previous week Range("B1").Select ActiveCell.FormulaR1C1 = "=R[3]C-6" Selection.NumberFormat = "dd" StartDatePrev = ActiveCell.Text Selection.NumberFormat = "mmm" MonthName1Prev = ActiveCell.Text Selection.NumberFormat = "yyyy" YearName1Prev = ActiveCell.Text ' Calculate end of the previous week Range("B2").Select ActiveCell.FormulaR1C1 = "=R[-1]C+6" Selection.NumberFormat = "dd" EndDatePrev = ActiveCell.Text Selection.NumberFormat = "mmm" MonthName2Prev = ActiveCell.Text Selection.NumberFormat = "yyyy" YearName2Prev = ActiveCell.Text ActiveWorkbook.Saved = True ActiveWindow.Close ' Reassign some variable names, as VBA won't accept integer variable in file name StartDateText = StartDate StartDatePrevText = StartDatePrev EndDateText = EndDate EndDatePrevText = EndDatePrev YearName1Text = YearName1 YearName1PrevText = YearName1Prev YearName2Text = YearName2 YearName2PrevText = YearName2Prev End Sub Sub mod11Sub4_CreateWorksheet() ' Determine name for last week's table worksheet If YearName1Prev = YearName2Prev Then If MonthName1Prev = MonthName2Prev Then ' Same year, same month TablesWorksheetPrev = "Wkly Rpt Tables " + MonthName1Prev + " " + StartDatePrevText + "-" + EndDatePrevText + ", " + YearName1PrevText + ".xls" Else 'Different months TablesWorksheetPrev = "Wkly Rpt Tables " + MonthName1Prev + " " + StartDatePrevText + "-" + MonthName2Prev + " " + EndDatePrevText + ", " + YearName2PrevText + ".xls" End If Else 'Different years, assume different months TablesWorksheetPrev = "Wkly Rpt Tables " + MonthName1Prev + " " + StartDatePrevText + ", " + YearName1PrevText + "-" + MonthName2Prev + " " + EndDatePrevText + ", " + YearName2PrevText + ".xls" End If ' Determine name for this week's table worksheet If YearName1 = YearName2 Then If MonthName1 = MonthName2 Then ' Same year, same month TablesWorksheetSave = "Wkly Rpt Tables " + MonthName1 + " " + StartDateText + "-" + EndDateText + ", " + YearName1Text Else 'Different months TablesWorksheetSave = "Wkly Rpt Tables " + MonthName1 + " " + StartDateText + "-" + MonthName2 + " " + EndDateText + ", " + YearName2Text End If Else 'Different years, assume different months TablesWorksheetSave = "Wkly Rpt Tables " + MonthName1 + " " + StartDateText + ", " + YearName1Text + "-" + MonthName2 + " " + EndDateText + ", " + YearName2Text End If TablesWorksheet = TablesWorksheetSave + ".xls" ' open last weeks Tables Workbook Workbooks.Open Filename:=TablesLocation + TablesWorksheetPrev ' open Tables template Workbooks.Open Filename:=TemplateLocation + m11_Template ' save Tables Workbook Template with this week's Table name ActiveWorkbook.SaveAs Filename:= _ TablesLocation + TablesWorksheet _ , FileFormat:=xlNormal ' Enter this report's ending date Sheets("Date Info").Select Range("A2").Select ActiveCell.FormulaR1C1 = WeekEndingDate ' grab 'beginning of fiscal year' and 'beginning of month' dates ' from last weeks Tables Windows(TablesWorksheetPrev).Activate Sheets("Date Info").Select Range("A5:C5").Select Selection.Copy ' Paste last week's 'beginning of fiscal year' and 'beginning of month' dates ' into the new Tables worksheet Windows(TablesWorksheet).Activate Sheets("Date Info").Select Range("A5:C5").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Update the current month, if necessary ' Range("B110").Select ' ActiveCell.FormulaR1C1 = "7/1/1998 12:00:00 AM" End Sub Sub mod11Sub5_TransferData() ' ============================================= ' Move last week's data to the last week columns of the this week's Table ' ============================================= ' Wkly Message Totals Windows(TablesWorksheetPrev).Activate Sheets("Tables").Select Range("B3:H3").Select Selection.Copy Windows(TablesWorksheet).Activate Sheets("Tables").Select Range("B2:H2").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Downtime will go here ' Windows(TablesWorksheetPrev).Activate ' Range("G5:H11").Select ' Application.CutCopyMode = False ' Selection.Copy ' Windows(TablesWorksheet).Activate ' Range("G15").Select ' Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ ' False, Transpose:=False ' On-Air MCT Count Windows(TablesWorksheetPrev).Activate Range("B22:H22").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B21:H21").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Cab Card Totals (customers) Windows(TablesWorksheetPrev).Activate Range("B32:H32").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B31:H31").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Cab Card Totals (msgs) Windows(TablesWorksheetPrev).Activate Range("B34:H34").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B33:H33").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Weekly Msg Totals from the Total Message Count worksheet TotalMessageWorksheet = m12_Workbook + "Week of " + StartDay + ".xls" Windows(TotalMessageWorksheet).Activate Sheets("Totals").Select Range("B11:H11").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B3:H3").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Peak Date Windows(TotalMessageWorksheet).Activate Range("B20").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B38").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Selection.NumberFormat = "ddd, mmm dd" ' Peak Daily Totals Windows(TotalMessageWorksheet).Activate Range("B32").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("D38").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Peak Daily Position Polls Windows(TotalMessageWorksheet).Activate Range("C32").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("F38").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Peak Daily Grand Totals Windows(TotalMessageWorksheet).Activate Range("D32").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("H38").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Close previous Tables worksheet, then save this week's Tables worksheet 'Windows(TablesWorksheetPrev).Activate 'ActiveWindow.Close Range("A1").Select Windows(TablesWorksheet).Activate ActiveWorkbook.Save End Sub ============== Private BlankWorkbook As String Private ExitFlag As Integer Private Graphs3 As String Private StartDay2 As String Private Tempname As String Private Tempname1 As String Private Tempname2 As String Private TotalsFileName As String Private TotalsFileNameSave As String Private WorksheetTemplate As String Sub mod12Sub1_TotalsMacro() ' This module extracts data from the Weekly data file, parses it, and uses formulas ' to come up with various totals for the weekly report. Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules mod12Sub2_CheckFlags If ExitFlag = 1 Then Exit Sub mod12Sub3_Init mod12Sub4_CreateWorksheet mod12Sub5_ExtractDataLoop mod12Sub6_AddFormulas mod12Sub7_SizePositionWorkbook Application.ScreenUpdating = True End Sub Sub mod12Sub2_CheckFlags() ' This sub checks various flags. If they're set it then sets the ExitFlag so this module ' will not run. It also sets the loop variable using info the user input at the menu, ' or if running in batch, it sets the loop to graph for all systems. 'If TotalsFlag = 0 Then ExitFlag = 1 LoopFrom = 1 LoopTo = TotalNumOfSys End Sub Sub mod12Sub3_Init() ' This sub defines the worksheet and template name variables. ' The file name variables in this module are changed in the ExtractDataLoop sub. WorksheetTemplate = TemplateLocation + m12_Template TotalsFileName = m12_Workbook + "Week of " + StartDay + ".xls" TotalsFileNameSave = GraphLocation + TotalsFileName End Sub Sub mod12Sub4_CreateWorksheet() Workbooks.OpenText Filename:= _ WorksheetTemplate, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) ActiveWorkbook.SaveAs Filename:=TotalsFileNameSave _ , FileFormat:=xlNormal ' This For-Next loop names the worksheets in this workbook, ' one worksheet for each system 'For NameSheet = 1 To LoopTo + 1 For NameSheet = 1 To 9 Tempname1 = NameSheet Tempname2 = NameSheet - 1 Tempname = "Sheet" + Tempname1 Sheets(Tempname).Select Sheets(Tempname).Name = "System " + Tempname2 Range("A1:G1").Select Selection.ColumnWidth = 12 Next NameSheet ' plus one called Totals Sheets("System 0").Select Sheets("System 0").Name = "Totals" ' This routine labels the rows and columns on the "Totals" worksheet Range("A1").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "System 1" Selection.AutoFill Destination:=Range("A1:H1"), Type:=xlFillDefault Range("A1:H1").Select Selection.ColumnWidth = 15 With Selection .HorizontalAlignment = xlCenter End With Selection.Font.Underline = xlSingle Range("A2").Select Selection.EntireColumn.Insert Columns("A:A").ColumnWidth = 12 Range("A3").Select ActiveCell.FormulaR1C1 = "Mon" Selection.AutoFill Destination:=Range("A3:A9"), Type:=xlFillDefault Range("A11").Select ActiveCell.FormulaR1C1 = "Total:" Range("A13").Select ActiveCell.FormulaR1C1 = "Grand Total:" Range("A18").Select ActiveCell.FormulaR1C1 = "System" Range("B18").Select ActiveCell.FormulaR1C1 = "Date" Range("C18").Select ActiveCell.FormulaR1C1 = "Comp. Polls" Range("D18").Select ActiveCell.FormulaR1C1 = "P. Polls" Range("E18").Select ActiveCell.FormulaR1C1 = "Total" Range("A20").Select ActiveCell.FormulaR1C1 = "Omni200" Range("A21").Select ActiveCell.FormulaR1C1 = "Omni202" Range("A22").Select ActiveCell.FormulaR1C1 = "Omni203" Range("A23").Select ActiveCell.FormulaR1C1 = "Omni204" Range("A24").Select ActiveCell.FormulaR1C1 = "Omni205" Range("A25").Select ActiveCell.FormulaR1C1 = "Omni206" Range("A26").Select ActiveCell.FormulaR1C1 = "Omni207" Range("A27").Select ActiveCell.FormulaR1C1 = "Omni208" Range("A29").Select ActiveCell.FormulaR1C1 = "Totals:" Range("A18:E18").Select Selection.ColumnWidth = 15 With Selection .HorizontalAlignment = xlCenter End With Selection.Font.Underline = xlSingle Range("A1").Select End Sub Sub mod12Sub5_ExtractDataLoop() ' This loop opens the SYSx_NMC.dat file for each system, ' and copies the data to the Totals worksheet. For Graphs = LoopFrom To LoopTo ' For Graphs = 1 To 7 SysNum = Graphs VaxFile1Import = "Sys" + SysNum + M3_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import Workbooks.OpenText Filename:= _ VaxFile1ImportOpen, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) Columns("A:A").Select Selection.Copy Windows(TotalsFileName).Activate Tempname = "System " + SysNum Sheets(Tempname).Select Range("A1").Select ActiveSheet.Paste ' This is just to clear the clipboard Range("K1").Select Selection.Copy ' Close the data file - no longer needed Windows(VaxFile1Import).Activate ActiveWindow.Close ' Start extracting the data here ' (delete most of the data, just leave the totals) Windows(TotalsFileName).Activate Range("A1:A174").Select Selection.EntireRow.Delete Range("A1:A7").Select Selection.TextToColumns Destination:=Range("A1"), DataType:= _ xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(8, 1), Array(21, 1), _ Array(28, 1), Array(40, 1), Array(47, 1), Array(53, 1)) ' Find the day with the highest total message count.... Range("G10").Select ActiveCell.FormulaR1C1 = "=MAX(R[-9]C[0]:R[-2]C[0])" HighestDaySearch = ActiveSheet.Range("G10").Value Range("G1").Select Cells.Find(What:=HighestDaySearch, after:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _ , MatchCase:=False).Activate ' ....and grab the data for that day Let TotalMessages = ActiveCell.Text ActiveCell.Offset(0, -2).Select Let TotalPosPolls = ActiveCell.Text ActiveCell.Offset(0, -2).Select Let TotalCompPolls = ActiveCell.Text ActiveCell.Offset(0, -2).Select Let TotalDate = ActiveCell.Text ' While we're here, grab the full weeks data (row 1 = Monday.......... row 7 = Sunday) Range("G1:G7").Select Application.CutCopyMode = False Selection.Copy Range("A1").Select ' Place all this data in the appropriate place on the Totals sheet Sheets("Totals").Select Range("A3").Select ActiveCell.Offset(, columnOffset:=Graphs).Activate ActiveSheet.Paste Range("B19").Select ActiveCell.Offset(RowOffset:=Graphs).Activate ActiveCell.FormulaR1C1 = TotalDate ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = TotalCompPolls ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = TotalPosPolls ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = TotalMessages ActiveCell.Offset(0, 1).Select ' Go do it again for the next system, until done Next Graphs End Sub Sub mod12Sub6_AddFormulas() ' Add Formulas and Formatting to Totals Worksheet Windows(TotalsFileName).Activate Range("B11:H11").Select Application.CutCopyMode = False Selection.FormulaR1C1 = "=SUM(R[-8]C:R[-1]C)" Range("B13").Select ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-2]C[6])" Range("B11:H13").Select Selection.NumberFormat = "###,##0" Range("B3:H9").Select Selection.NumberFormat = "###,##0" Range("C28:E28").Select Application.CutCopyMode = False Selection.FormulaR1C1 = "=SUM(R[-8]C:R[-1]C)" Range("C20:E28").Select Selection.NumberFormat = "###,##0" Range("B20:B26").Select Selection.NumberFormat = "ddd, mmm dd" ' Format for easy cut and paste to Weekly Peak Traffic Range("B31").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "Totals" ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = "Position Polls" ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = "Grand Total" Range("B32").Select ActiveCell.FormulaR1C1 = "=R[-4]C[3]" ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = "=R[-4]C[1]" ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = "=SUM(RC[-2]:RC[-1])" ' Format for easy cut and paste to Weekly Message Totals Range("G18").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "Weekly Msg Totals" Selection.Font.Underline = xlSingle Range("G20").Select ActiveCell.FormulaR1C1 = "=R[-9]C[-5]" Range("G21").Select ActiveCell.FormulaR1C1 = "=R[-10]C[-4]" Range("G22").Select ActiveCell.FormulaR1C1 = "=R[-11]C[-3]" Range("G23").Select ActiveCell.FormulaR1C1 = "=R[-12]C[-2]" Range("G24").Select ActiveCell.FormulaR1C1 = "=R[-13]C[-1]" Range("G25").Select ActiveCell.FormulaR1C1 = "=R[-14]C[0]" Range("G26").Select ActiveCell.FormulaR1C1 = "=R[-15]C[1]" Range("G27").Select ActiveCell.FormulaR1C1 = "=R[-16]C[2]" ' Add colors for easy view of needed selections Range("B11:I11").Select With Selection.Interior .ColorIndex = 6 .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With Range("B32:D32").Select With Selection.Interior .ColorIndex = 45 .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With Range("A1").Select End Sub Sub mod12Sub7_SizePositionWorkbook() ' This determines the location of the Workbook on the screen If LapTopFlag = 0 Then With ActiveWindow .Width = 200 .Height = 100 .Top = 300 .Left = 620 End With Else With ActiveWindow .Width = 100 .Height = 50 .Top = 200 .Left = 100 End With End If ActiveWorkbook.Save End Sub ====== Private ExitFlag As Integer Sub Mod13Sub1_PrintGraphsMacro() ' Prints the graphs in the order used in the Weekly Report Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules Mod13Sub2_MenuCheck If ExitFlag = 1 Then Exit Sub Mod13Sub3_Init 'not needed at this time Mod13Sub4_PrintWeekly Mod13Sub5_PrintDaily MsgBox ("1/4 submitted") Mod13Sub6_PrintFlpRlp MsgBox ("1/2 submitted") Mod13Sub7_PrintPollClass MsgBox ("3/4 submitted") Mod13Sub8_PrintBarCharts Mod13Sub9_CleanUp 'not needed at this time Application.ScreenUpdating = True End Sub Sub Mod13Sub2_MenuCheck() ' This sub checks various flags. If they're set it then sets the ExitFlag so this module ' will not run. It also sets the loop variable using info the user input at the menu, ' or if running in batch, it sets the loop to graph for all systems. If MenuFlag = 1 Then If HtmlFlag = 1 Then ExitFlag = 1 If PrintFlag = 0 Then ExitFlag = 1 End If End Sub Sub Mod13Sub3_Init() ' All file renaming in this module done in the subroutines themselves. End Sub Sub Mod13Sub4_PrintWeekly() ' Print Weekly Graphs If WeekFrom = 0 Then Exit Sub If MenuFlag = 1 Then LoopFrom = WeekFrom LoopTo = WeekTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If For Graphs = LoopFrom To LoopTo SysNum = Graphs Filename = M3_Workbook + SysNum + " Week of " + StartDay + ".xls" Windows(Filename).Activate Sheets("Weekly Graph").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next Graphs End Sub Sub Mod13Sub5_PrintDaily() ' Print Daily Graphs If WeekFrom = 0 Then Exit Sub If MenuFlag = 1 Then LoopFrom = WeekFrom LoopTo = WeekTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If For Graphs = LoopFrom To LoopTo If WeekFrom = 0 Then Exit For SysNum = Graphs Filename = M3_Workbook + SysNum + " Week of " + StartDay + ".xls" Windows(Filename).Activate Sheets("Daily Graph").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next Graphs End Sub Sub Mod13Sub6_PrintFlpRlp() ' Print FLP & RLP Graphs If FlpFrom = 0 Then Exit Sub If MenuFlag = 1 Then LoopFrom = FlpFrom LoopTo = FlpTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If For Graphs = LoopFrom To LoopTo SysNum = Graphs Filename = M5_Workbook1 + SysNum + " Week of " + StartDay + ".xls" Windows(Filename).Activate Sheets("FLP Graph").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sheets("RLP Graph").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next Graphs End Sub Sub Mod13Sub7_PrintPollClass() ' Print Poll Class Graphs If PollFrom = 0 Then Exit Sub If MenuFlag = 1 Then LoopFrom = PollFrom LoopTo = PollTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If For Graphs = LoopFrom To LoopTo SysNum = Graphs Filename = M6_Workbook + SysNum + " Week of " + StartDay + ".xls" Windows(Filename).Activate Sheets("RLR Summary").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sheets("Poll Class 2 Graph").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sheets("Poll Class 3 Graph").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next Graphs End Sub Sub Mod13Sub8_PrintBarCharts() ' Print Bar Charts If WeekFrom = 0 Then Exit Sub If MenuFlag = 1 Then LoopFrom = WeekFrom LoopTo = WeekTo Else LoopFrom = 1 LoopTo = TotalNumOfSys End If For Graphs = LoopFrom To LoopTo SysNum = Graphs Filename = M3_Workbook + SysNum + " Week of " + StartDay + ".xls" Windows(Filename).Activate Sheets("Barchart Graph").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sheets("Barchart Graph2").Select Range("A1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next Graphs End Sub Sub Mod13Sub9_CleanUp() End Sub ======= Sub Mod15Sub1_CleanUp() Mod15Sub2_FanWindowsMacro End Sub Sub Mod15Sub2_FanWindowsMacro() ' This subroutine goes out and "touches" each of the open worksheets in a particular ' order so that when the macro is finished, all the worksheet names are visible. On Error GoTo FanExit ' If a complete set of graphs isn't open, this procedure errors and exits ' Clean up Weekly Graphs For Graphs = 1 To TotalNumOfSys SysNum = Graphs Filename = M3_Workbook + SysNum + " Week of " + StartDay + ".xls" Windows(Filename).Activate Next Graphs ' Clean up FLP & RLP Graphs For Graphs = 1 To TotalNumOfSys SysNum = Graphs Filename = M5_Workbook1 + SysNum + " Week of " + StartDay + ".xls" Windows(Filename).Activate Next Graphs ' Clean up Poll Class Graphs For Graphs = 1 To TotalNumOfSys SysNum = Graphs Filename = M6_Workbook + SysNum + " Week of " + StartDay + ".xls" Windows(Filename).Activate Next Graphs ' Clean up HTML Graphs For Graphs = 1 To TotalNumOfSys SysNum = Graphs Filename = EndWeek + "_Sys" + SysNum + ".xls" Windows(Filename).Activate Next Graphs Windows(MacroFileName).Activate FanExit: Windows(MacroFileName).Activate Exit Sub End Sub $$$$$ Qcom TablesMacro Code $$$ Sub Mod1Sub1_ModuleCalls() ' This module simply calls all the rest of the macro modules. Mod2Sub1_InitSetup ' Mod3Sub1_ConfirmDates If TotalsFlag = 0 Then MsgBox ("Needed Data Files Not Found - macro will end now") Exit Sub End If Mod4Sub1_WeeklyTotalsMacro ' Mod5Sub1_CabCardMacro mod7Sub1_CpMacro ' Mod9Sub1_OnAirCountMacro ' Mod11Sub1_CopyDataMacro Mod15Sub1_CleanUp Windows(MacroFileName).Activate MsgBox ("The macro has completed.") ' MsgBox Prompt:=variable End Sub ' flag declarations Public LapTopFlag As Integer Public TotalsFlag As Integer ' directory location declarations Public DataLocation As String Public GraphLocation As String Public MacroLocation As String Public TablesLocation As String Public TemplateLocation As String ' misc variable declarations Public EndDay As String Public EndWeek As String Public Graphs As Integer Private Loop1 As Integer Public LoopFrom As Integer Public LoopTo As Integer Private M4Text Private M5Text Private M7Text Private M9Text Private NameSheet As String Public StartDay As String Public SysNum As String Private TempName1 As String Private TempName2 As String Private TempName3 As String Public TotalNumOfSys As Integer ' file name declarations Public GraphsAndWorksheets As String Public GraphsAndWorksheetsSave As String Public GraphsandWorksheetsTemplateOpen As String Public MacroFileName As String Public VaxFile1Import Public VaxFile2Import Public VaxFile1ImportOpen As String Public VaxFile2ImportOpen As String Public M2_Template As String Public M2_Workbook As String Private TablesFileName As String Private TablesFileNameSave As String Public M4_VaxFile1 As String Public M4_Template As String Public M4_Workbook As String Public M5_VaxFile1 As String Public M5_Template As String Public M5_Workbook1 As String Public M7_VaxFile1 As String Public M7_Workbook As String Public M9_VaxFile1 As String Sub Mod2Sub1_InitSetup() 'This module does the initial housekeeping chores. Application.ScreenUpdating = False TotalsFlag = 1 ' Can later be set to 0, in order to exit entire Macro LapTopFlag = 0 ' Laptop uses different file locations and window sizes ' Mod2Sub2_ ' available for expansion Mod2Sub3_FileNamesAndLocations Mod2Sub4_MiscItems Mod2Sub6_CheckWeekly Mod2Sub8_CheckCabCard Mod2Subb10_CheckCP Mod2Subb12_CheckOnAir Mod2Subb14_ConfirmDates Mod2Subb16_CreateWorksheet Application.ScreenUpdating = True End Sub Sub Mod2Sub3_FileNamesAndLocations() ' This is where the macro and data file names and locations are defined. ' Define locations where the macro will read/write to and from: If LapTopFlag = 0 Then ' if using a desktop networked computer MacroFileName = "OmniTablesMacro.xls" MacroLocation = "Y:\Public\Graphs\_Macros\" DataLocation = "Y:\public\graphs\_Data\" GraphLocation = "Y:\public\graphs\_Graphs\" TablesLocation = "Y:\public\graphs\_Tables\" TemplateLocation = "Y:\public\graphs\_templates\" Else ' if using the laptop or not connected to network MacroFileName = "OmniTablesMacro.xls" MacroLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Macros\" DataLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Data\" GraphLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Graphs\" TablesLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Tables\" TemplateLocation = "C:\WINDOWS\Desktop\Rick's Excel Stuff\_Templates\" End If ' Names of the Data Files the macro will open: ' (If a system number is part of the file name, it is ' defined in the Init sub of the module itself.) ' Module 2: InitSetup M2_Template = "zz Blank Workbook.xls" M2_Workbook = "Tables Data " ' Module 4: Totals Macro M4_VaxFile1 = "_Nmc.txt" M4_Template = "zz Blank Workbook.xls" M4_Workbook = M2_Workbook ' Module 5: CabCard Macro ' M5_VaxFile1 = "_" ' M5_Template = "zz FlpRlp Graphs Template.xls" M5_Workbook = M2_Workbook ' M5_Workbook2 = "DailyFLP_" ' Module 7: CP Macro M7_VaxFile1 = "CP_Antennas.out" M7_Workbook = M2_Workbook ' Module 9: OnAirCountMacro ' M9_Template = "zz Html Template.xls" ' M9_Workbook = must be defined in Mod__7, because the macro doesn't ' know the date yet at this point ' Module 11: CopyDataMacro m11_Template = "zz WklyRptTables Template.xls" End Sub Sub Mod2Sub4_MiscItems() ' This is the number of Omni systems the macro will assume have provided data. TotalNumOfSys = 8 ' This sizes and positions the Excel macro itself Windows(MacroFileName).Activate ActiveWindow.WindowState = xlNormal With ActiveWindow .Width = 175 .Height = 95 If LapTopFlag = 0 Then 'using desktop networked computer .Top = 350 .Left = 425 Else ' using laptop or non-networked computer .Top = 240 .Left = 240 End If End With End Sub Sub Mod2Sub6_CheckWeekly() ' The Sub gets the dates of the Weekly Totals data file for System 1. ' Later, the macro will ask the user to verify that the date range is correct. VaxFile1Import = "Sys1" + M4_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import On Error GoTo NoDataWeekly: Workbooks.OpenText Filename:= _ VaxFile1ImportOpen _ , Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(10, 1), Array(18, 1), Array(30, 1), _ Array(43, 1), Array(54, 1), Array(66, 1)) On Error GoTo 0 Columns("A:A").ColumnWidth = 20 Range("A1:A5").Select Selection.EntireRow.Insert ' Get beginning of week date Range("A12").Select Selection.Copy Range("A1").Select ActiveSheet.Paste Range("A1").Select Selection.NumberFormat = "mmmm d" StartDay = ActiveCell.Text ' Get end of week date Range("A179").Select Application.CutCopyMode = False Selection.Copy Range("A2").Select ActiveSheet.Paste Selection.NumberFormat = "mmmm d, yyyy" EndDay = ActiveCell.Text Selection.Copy Range("A3").Select ActiveSheet.Paste Selection.NumberFormat = "mmddyy" EndWeek = ActiveCell.Text ' Done with the data file, close it ActiveWorkbook.Saved = True ActiveWindow.Close Exit Sub NoDataWeekly: TotalsFlag = 0 M4Text = "Weekly Data File " + M4_VaxFile1 + " Not Found" End Sub Sub Mod2Sub8_CheckCabCard() ' The Sub gets the dates of the CabCard data file. ' Later, the macro will ask the user to verify that the date range is correct. VaxFile1Import = M5_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import On Error GoTo NoDataCabCard: ' Workbooks.OpenText Filename:= _ ' VaxFile1ImportOpen _ ' , Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, _ ' FieldInfo:=Array(Array(0, 1), Array(10, 1), Array(18, 1), Array(30, 1), _ ' Array(43, 1), Array(54, 1), Array(66, 1)) On Error GoTo 0 Exit Sub NoDataCabCard: TotalsFlag = 0 M5Text = "CabCard Data File " + M5_VaxFile1 + " Not Found" End Sub Sub Mod2Subb10_CheckCP() ' The Sub gets the date of the CP data file. ' Later, the macro will ask the user to verify that the date range is correct. VaxFile1Import = M7_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import On Error GoTo NoDataCP: ' Workbooks.OpenText Filename:= _ ' VaxFile1ImportOpen _ ' , Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, _ ' FieldInfo:=Array(Array(0, 1), Array(10, 1), Array(18, 1), Array(30, 1), _ ' Array(43, 1), Array(54, 1), Array(66, 1)) On Error GoTo 0 Exit Sub NoDataCP: TotalsFlag = 0 M7Text = "CP Data File " + M7_VaxFile1 + " Not Found" End Sub Sub Mod2Subb12_CheckOnAir() ' The Sub gets the date of the MCT OnAirCount data file. ' Later, the macro will ask the user to verify that the date range is correct. VaxFile1Import = M9_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import On Error GoTo NoDataOnAir: ' Workbooks.OpenText Filename:= _ ' VaxFile1ImportOpen _ ' , Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, _ ' FieldInfo:=Array(Array(0, 1), Array(10, 1), Array(18, 1), Array(30, 1), _ ' Array(43, 1), Array(54, 1), Array(66, 1)) On Error GoTo 0 Exit Sub NoDataOnAir: TotalsFlag = 0 M9Text = "CP Data File " + M9_VaxFile1 + " Not Found" End Sub Sub Mod2Subb14_ConfirmDates() End Sub Sub Mod2Subb16_CreateWorksheet() WorksheetTemplate = TemplateLocation + M2_Template TableDataFileName = M2_Workbook + "Week of " + StartDay + ".xls" TableDataFileNameSave = GraphLocation + TableDataFileName Workbooks.OpenText Filename:= _ WorksheetTemplate, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) ActiveWorkbook.SaveAs Filename:=TableDataFileNameSave, _ FileFormat:=xlNormal ' This For-Next loop names the worksheets in this workbook Sheets("Sheet1").Name = "WeeklyTotals" Sheets("Sheet2").Name = "CabCard" Sheets("Sheet3").Name = "CP" Sheets("Sheet4").Name = "OnAirCount" ' This convuluted loop names 1 worksheet for each system ' These worksheets are used in Mod__4_WeeklyTotalsMacro For Loop1 = 5 To TotalNumOfSys + 4 TempName1 = Loop1 TempName2 = Loop1 - 4 TempName3 = "Sheet" + TempName1 'Sheets(TempName3).Select Sheets(TempName3).Name = "System " + TempName2 Range("A1:Z1").Select Selection.ColumnWidth = 12 Next Loop1 ' This routine labels the rows and columns on the "Totals" worksheet ' First, do System labels across top row Sheets("WeeklyTotals").Select Range("A1").Select For Loop1 = 1 To TotalNumOfSys Application.CutCopyMode = False SysNum = Loop1 ActiveCell.FormulaR1C1 = "System " + SysNum With Selection .ColumnWidth = 15 .HorizontalAlignment = xlCenter .Font.Underline = xlSingle End With ActiveCell.Offset(0, 1).Select Next Loop1 Range("A2").Select Selection.EntireColumn.Insert Columns("A:A").ColumnWidth = 12 Range("A3").Select ActiveCell.FormulaR1C1 = "Mon" Selection.AutoFill Destination:=Range("A3:A9"), Type:=xlFillDefault Range("A11").Select ActiveCell.FormulaR1C1 = "Total:" Range("A13").Select ActiveCell.FormulaR1C1 = "Grand Total:" Range("A18").Select ActiveCell.FormulaR1C1 = "System" Range("B18").Select ActiveCell.FormulaR1C1 = "Date" Range("C18").Select ActiveCell.FormulaR1C1 = "Comp. Polls" Range("D18").Select ActiveCell.FormulaR1C1 = "P. Polls" Range("E18").Select ActiveCell.FormulaR1C1 = "Total" Range("A20").Select ActiveCell.FormulaR1C1 = "Omni200" Range("A21").Select For Loop1 = 2 To TotalNumOfSys SysNum = Loop1 If Loop1 < 10 Then ActiveCell.FormulaR1C1 = "Omni20" + SysNum Else ActiveCell.FormulaR1C1 = "Omni2" + SysNum End If ActiveCell.Offset(1, 0).Select Next Loop1 ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = "Totals:" LastRow = Selection.Address Range("A18:E18").Select With Selection .ColumnWidth = 15 .HorizontalAlignment = xlCenter .Font.Underline = xlSingle End With Range("A1").Select ActiveWorkbook.Save End Sub Private BlankWorkbook As String Private ExitFlag As Integer Private Graphs As Integer Private Loop1 As Integer Private LastColumn As String Private LastRow As String Private StartDay2 As String Private SysNum As String Private TempAddress1 As String Private TempAddress2 As String Private TempName As String Private TempName1 As String Private TempName2 As String Private TotalsFileName As String Private TotalsFileNameSave As String Private WorksheetTemplate As String Dim MsgTotalsArray(1 To 15) As Variant Sub Mod4Sub1_WeeklyTotalsMacro() ' This module extracts data from the Weekly data files, parses it, and uses formulas ' to find various totals for the Weekly Report Tables. Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules Mod4Sub2_CheckFlags If ExitFlag = 1 Then Exit Sub Mod4Sub3_Init ' Mod4Sub4_CreateWorksheet Mod4Sub5_ExtractDataLoop Mod4Sub6_AddFormulas Mod4Sub7_SizePositionWorkbook Application.ScreenUpdating = True End Sub Sub Mod4Sub2_CheckFlags() ' This sub checks various flags. Depending on how they're set, it then sets the ExitFlag ' so this module will not run. It also sets the loop variable to do all systems. ' Check to see if the data files are available. If TotalsFlag = 0 Then ExitFlag = 1 LoopFrom = 1 LoopTo = TotalNumOfSys End Sub Sub Mod4Sub3_Init() ' This sub defines the worksheet and template name variables. ' The file name variables in this module are changed in the ExtractDataLoop sub. TotalsFileName = M4_Workbook + "Week of " + StartDay + ".xls" TotalsFileNameSave = GraphLocation + TotalsFileName End Sub Sub Mod4Sub4_CreateWorksheet() Workbooks.OpenText Filename:= _ WorksheetTemplate, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) ActiveWorkbook.SaveAs Filename:=TotalsFileNameSave, _ FileFormat:=xlNormal ' This For-Next loop names the worksheets in this workbook, ' one worksheet for each system For NameSheet = 1 To LoopTo + 1 TempName1 = NameSheet TempName2 = NameSheet - 1 TempName = "Sheet" + TempName1 Sheets(TempName).Select Sheets(TempName).Name = "System " + TempName2 Range("A1:Z1").Select Selection.ColumnWidth = 12 Next NameSheet ' plus one called Totals Sheets("System 0").Select Sheets("System 0").Name = "Totals" ' This routine labels the rows and columns on the "Totals" worksheet ' First, do System labels across top row Range("A1").Select For Loop1 = 1 To LoopTo Application.CutCopyMode = False SysNum = Loop1 ActiveCell.FormulaR1C1 = "System " + SysNum With Selection .ColumnWidth = 15 .HorizontalAlignment = xlCenter .Font.Underline = xlSingle End With ActiveCell.Offset(0, 1).Select Next Loop1 ' Determine where the last column's totals will go ActiveCell.Offset(10, 0).Select LastColumn = Selection.Address Range("A2").Select Selection.EntireColumn.Insert Columns("A:A").ColumnWidth = 12 Range("A3").Select ActiveCell.FormulaR1C1 = "Mon" Selection.AutoFill Destination:=Range("A3:A9"), Type:=xlFillDefault Range("A11").Select ActiveCell.FormulaR1C1 = "Total:" Range("A13").Select ActiveCell.FormulaR1C1 = "Grand Total:" Range("A18").Select ActiveCell.FormulaR1C1 = "System" Range("B18").Select ActiveCell.FormulaR1C1 = "Date" Range("C18").Select ActiveCell.FormulaR1C1 = "Comp. Polls" Range("D18").Select ActiveCell.FormulaR1C1 = "P. Polls" Range("E18").Select ActiveCell.FormulaR1C1 = "Total" Range("A20").Select ActiveCell.FormulaR1C1 = "Omni200" Range("A21").Select For Loop1 = 2 To LoopTo SysNum = Loop1 If Loop1 < 10 Then ActiveCell.FormulaR1C1 = "Omni20" + SysNum Else ActiveCell.FormulaR1C1 = "Omni2" + SysNum End If ActiveCell.Offset(1, 0).Select Next Loop1 ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = "Totals:" LastRow = Selection.Address Range("A18:E18").Select With Selection .ColumnWidth = 15 .HorizontalAlignment = xlCenter .Font.Underline = xlSingle End With Range("A1").Select End Sub Sub Mod4Sub5_ExtractDataLoop() ' This loop opens the SYSx_NMC.dat file for each system, ' and copies the data to the Totals worksheet. For Graphs = LoopFrom To LoopTo SysNum = Graphs VaxFile1Import = "Sys" + SysNum + M4_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import Workbooks.OpenText Filename:= _ VaxFile1ImportOpen, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) Columns("A:A").Select Selection.Copy Windows(TotalsFileName).Activate TempName = "System " + SysNum Sheets(TempName).Select Range("A1").Select ActiveSheet.Paste ' This is just to clear the clipboard Range("K1").Select Selection.Copy ' Close the data file - no longer needed Windows(VaxFile1Import).Activate ActiveWindow.Close ' Start extracting the data here ' (delete most of the data, just leave the totals) Windows(TotalsFileName).Activate Range("A1:A174").Select Selection.EntireRow.Delete Range("A1:A7").Select Selection.TextToColumns Destination:=Range("A1"), DataType:= _ xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(8, 1), Array(21, 1), _ Array(28, 1), Array(40, 1), Array(47, 1), Array(53, 1)) ' Find the day with the highest total message count.... Range("G10").Select ActiveCell.FormulaR1C1 = "=MAX(R[-9]C[0]:R[-2]C[0])" HighestDaySearch = ActiveSheet.Range("G10").Value Range("G1").Select Cells.Find(What:=HighestDaySearch, After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _ , MatchCase:=False).Activate ' ....and grab the data for that day Let TotalMessages = ActiveCell.Text ActiveCell.Offset(0, -2).Select Let TotalPosPolls = ActiveCell.Text ActiveCell.Offset(0, -2).Select Let TotalCompPolls = ActiveCell.Text ActiveCell.Offset(0, -2).Select Let TotalDate = ActiveCell.Text ' While we're here, grab the full weeks data (row 1 = Monday.......... row 7 = Sunday) Range("G1:G7").Select Application.CutCopyMode = False Selection.Copy Range("A1").Select ' Place all this data in the appropriate place on the Totals sheet Sheets("WeeklyTotals").Select Range("A3").Select ActiveCell.Offset(, columnOffset:=Graphs).Activate ActiveSheet.Paste Range("B19").Select ActiveCell.Offset(RowOffset:=Graphs).Activate ActiveCell.FormulaR1C1 = TotalDate ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = TotalCompPolls ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = TotalPosPolls ActiveCell.Offset(0, 1).Select ActiveCell.FormulaR1C1 = TotalMessages ActiveCell.Offset(0, 1).Select ' Go do it again for the next system, until done Next Graphs End Sub Sub Mod4Sub6_AddFormulas() ' Add Formulas and Formatting to Totals Worksheet ' Determine where the last column's totals will go Range("B1").End(xlToRight).Select ActiveCell.Offset(10, 0).Select LastColumn = Selection.Address ' Determine where the last column's totals will go Range("A20").Select ActiveCell.Offset(TotalNumOfSys + 1, 0).Select ' Cells.Find(What:="Totals:", after:=ActiveCell, LookIn:=xlFormulas, _ ' LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _ ' , MatchCase:=False).Activate LastRow = Selection.Address ' Total Messages for the Week for each System Windows(TotalsFileName).Activate Range("B11", LastColumn).Select Application.CutCopyMode = False Selection.FormulaR1C1 = "=SUM(R[-8]C:R[-1]C)" ' Grand Total of all Messaging for the Week Range("B13").Select Selection.NumberFormat = "###,##0" ' NewSys: last number in next line needs to be Total Number of Systems minus 1 ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-2]C[7])" 'ActiveCell.FormulaA1 = "=SUM("B11", LastColumn)" Range("B3", LastColumn).Select Selection.NumberFormat = "###,##0" ' Add highlight color Range("B11", LastColumn).Select With Selection.Interior .ColorIndex = 6 .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With ' Polls Totals of all Systems for the Week Range(LastRow).Select TempAddress1 = ActiveCell.Offset(0, 2).Address TempAddress2 = ActiveCell.Offset(0, 4).Address Range(TempAddress1, TempAddress2).Select Application.CutCopyMode = False ' NewSys: first number in next line needs to be Total Number of Systems plus 1 Selection.FormulaR1C1 = "=SUM(R[-9]C:R[-2]C)" Selection.NumberFormat = "###,##0" Range(LastRow).Select TempAddress1 = ActiveCell.Offset(-2, 4).Address Range("C20", TempAddress1).Select Selection.NumberFormat = "###,##0" Range(LastRow).Select TempAddress1 = ActiveCell.Offset(-2, 1).Address Range("B20", TempAddress1).Select Selection.NumberFormat = "ddd, mmm dd" ' Format for easy cut and paste to Weekly Peak Traffic ' (this simply copies the Poll totals to another row of cells, ' and arranges them in a different order) Range(LastRow).Select ActiveCell.Offset(2, 1).Select TempAddress1 = ActiveCell.Offset(1, 0).Address TempAddress2 = ActiveCell.Offset(1, 2).Address Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "Totals" ActiveCell.Offset(0, 1).FormulaR1C1 = "Position Polls" ActiveCell.Offset(0, 2).FormulaR1C1 = "Grand Total" Range(TempAddress1).Select ActiveCell.FormulaR1C1 = "=R[-3]C[3]" ActiveCell.Offset(0, 1).FormulaR1C1 = "=R[-3]C[1]" ActiveCell.Offset(0, 2).FormulaR1C1 = "=SUM(RC[-2]:RC[-1])" Range(TempAddress1, TempAddress2).Select With Selection.Interior .ColorIndex = 45 .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With Range("A1").Select End Sub Sub Mod4Sub7_SizePositionWorkbook() ' This determines the location of the Workbook on the screen ' ====== Just temporary sizing - delete this With ActiveWindow .Width = 500 .Height = 100 .Top = 1 .Left = 1 End With ActiveWorkbook.Save Exit Sub ' ============================== If LapTopFlag = 0 Then With ActiveWindow .Width = 200 .Height = 100 .Top = 300 .Left = 620 End With Else With ActiveWindow .Width = 100 .Height = 50 .Top = 200 .Left = 100 End With End If End Sub Private BlankWorkbook As String Private CPFileName As String Private CPFileNameSave As String Private ExitFlag As Integer Private Graphs As Integer Private Loop1 As Integer Private Loop2 As Integer Private LastColumn As String Private LastRow As String Private Search1 As String Private StartDay2 As String Private SysNum As String Private TempAddress1 As String Private TempAddress2 As String Private TempName1 As String Private TempName2 As String Private TempName3 As String Private TempName4 As String Private TempName5 As String Dim BegEndAddArray(1 To 15, 1 To 2) As Variant Dim FinalDataArray(1 To 15, 1 To 3) As Variant Sub mod7Sub1_CpMacro() ' This module parses and totals the CP (circularly polarized antenna) data. Application.ScreenUpdating = False ExitFlag = 0 ' added because private variable is (apparently) ' sometimes passing value between modules Mod7Sub2_CheckFlags If ExitFlag = 1 Then Exit Sub Mod7Sub3_Init Mod7Sub5_PrepData Mod7Sub7_AddFormulas Mod7Sub9_TransferData Mod7Subb11_CleanUp Application.ScreenUpdating = True End Sub Sub Mod7Sub2_CheckFlags() ' Haven't needed to check for any Flags yet. End Sub Sub Mod7Sub3_Init() ' This sub defines the worksheet name variables. CPFileName = M7_Workbook + "Week of " + StartDay + ".xls" CPFileNameSave = GraphLocation + CPFileName VaxFile1Import = M7_VaxFile1 VaxFile1ImportOpen = DataLocation + VaxFile1Import End Sub Sub Mod7Sub5_PrepData() ' This sub opens the CP data file, parses it, and formats area for ' the data that will be copied to the Table worksheet ' Open the data file, copy to the Tables Data worksheet Workbooks.OpenText Filename:= _ VaxFile1ImportOpen, Origin:= _ xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _ Array(0, 1) Columns("A:A").Select Selection.Copy Windows(CPFileName).Activate Sheets("CP").Select Range("A1").Select ActiveSheet.Paste ' This is to clear the clipboard Application.CutCopyMode = False ' Close the Vax data file Windows(VaxFile1Import).Activate ActiveWindow.Close ' Parse the CP data Windows(CPFileName).Activate Columns("A:A").Select Application.CutCopyMode = False ' Selection.TextToColumns Destination:=Range("A1"), DataType:= _ ' xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _ ' :=False, Tab:=True, Semicolon:=False, Comma:=False, Space _ ' :=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _ ' Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), _ ' Array(8, 1), Array(9, 1), Array(10, 1)) Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(39, 1), Array(50, 1), Array(56, 1), Array(65, 1), _ Array(74, 1)) ' Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ ' TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ ' Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ ' :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _ ' Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)) ' Size columns Columns("A:A").ColumnWidth = 40 ' Make space for Tables info Rows("2:6").Select Selection.Insert Shift:=xlDown ' Create Tables info headers ' System numbers at top of columns Range("B3").Select ActiveCell.FormulaR1C1 = "Omni200" ActiveCell.Offset(0, 1).Select For Loop1 = 2 To TotalNumOfSys SysNum = Loop1 If Loop1 < 10 Then ActiveCell.FormulaR1C1 = "Omni20" + SysNum Else ActiveCell.FormulaR1C1 = "Omni2" + SysNum End If ActiveCell.Offset(0, 1).Select Next Loop1 LastColumn = Selection.Address ' Data labels along side rows Range("A4").Select ActiveCell.FormulaR1C1 = "CP Antennas" ActiveCell.Offset(1, 0).FormulaR1C1 = "Linear Antennas" ActiveCell.Offset(2, 0).FormulaR1C1 = "Mixed Fleets" ActiveCell.Offset(3, 0).FormulaR1C1 = "Splits" ' Highlight labels Range("A4:A7").Select With Selection .HorizontalAlignment = xlRight .Font.Name = "Arial" .Font.FontStyle = "Bold" End With Range("B3", LastColumn).Select With Selection.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 .Underline = xlUnderlineStyleSingle End With ' Find the beginning and ending address of all the data Range("A6").Select For Loop1 = 1 To TotalNumOfSys SysNum = Loop1 ActiveCell.Offset(5, 0).Select BegEndAddArray(Loop1, 1) = Selection.Address Range(BegEndAddArray(Loop1, 1)).End(xlDown).Select ActiveCell.Offset(-1, 0).Select BegEndAddArray(Loop1, 2) = Selection.Address Next Loop1 ' Add labels above each system's data For Loop1 = 1 To TotalNumOfSys SysNum = Loop1 Range(BegEndAddArray(Loop1, 1)).Select ActiveCell.Offset(-1, 0).Select Selection.Characters.Text = "Customer" ActiveCell.Offset(0, 1).Characters.Text = "ACCOUNT #" ActiveCell.Offset(0, 2).Characters.Text = "CP" ActiveCell.Offset(0, 3).Characters.Text = "NON-CP" ActiveCell.Offset(0, 4).Characters.Text = "CP-IMCTs" ActiveCell.Offset(0, 5).Characters.Text = "TOTALS" ActiveCell.Offset(0, 6).Characters.Text = "MIXED" ActiveCell.Offset(0, 7).Characters.Text = "" ActiveCell.Offset(0, 8).Characters.Text = "" ActiveCell.Offset(0, 9).Characters.Text = "" ActiveCell.Offset(0, 10).Characters.Text = "" Range(ActiveCell, ActiveCell.Offset(0, 6)).Select With Selection .HorizontalAlignment = xlCenter .Font.FontStyle = "Bold" .Font.Underline = xlUnderlineStyleSingle End With Next Loop1 End Sub Sub Mod7Sub7_AddFormulas() ' Add Mixed formula to System 1, Cell G11, to be pasted to the rest of the systems Range("G11").Formula = "=If(C11+E11=0,0,IF(D11=0,0,1))" ' Begin adding totals and formulas to each system For Loop1 = 1 To TotalNumOfSys SysNum = Loop1 'Add Mixed formula to all Systems TempAddress1 = Range(BegEndAddArray(Loop1, 1)).Offset(0, 6).Address TempAddress2 = Range(BegEndAddArray(Loop1, 2)).Offset(0, 6).Address Range("G11").Copy Range(TempAddress1).Select ActiveSheet.Paste Range(TempAddress1, TempAddress2).Select Selection.FillDown ' Total up each systems data For Loop2 = 1 To 5 TempAddress1 = Range(BegEndAddArray(Loop1, 1)).Offset(0, Loop2 + 1).Address TempAddress2 = Range(BegEndAddArray(Loop1, 2)).Offset(0, Loop2 + 1).Address Range(BegEndAddArray(Loop1, 2)).Offset(1, Loop2 + 1).Select ActiveCell.Formula = "=SUM(" & TempAddress1 & ":" & TempAddress2 & ")" ' Add CP units together If Loop2 = 3 Then ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = "=SUM(R[-1]C[-2]+R[-1]C)" End If Next Loop2 Next Loop1 End Sub Sub Mod7Sub9_TransferData() ' Get Data totals For Loop1 = 1 To TotalNumOfSys Range(BegEndAddArray(Loop1, 2)).Offset(2, 4).Select FinalDataArray(Loop1, 1) = Selection.Value FinalDataArray(Loop1, 2) = ActiveCell.Offset(-1, -1).Value FinalDataArray(Loop1, 3) = ActiveCell.Offset(-1, 2).Value Next Loop1 ' Transfer to top of worksheet Range("B4").Select For Loop1 = 1 To TotalNumOfSys ActiveCell.FormulaR1C1 = FinalDataArray(Loop1, 1) ActiveCell.Offset(1, 0).FormulaR1C1 = FinalDataArray(Loop1, 2) ActiveCell.Offset(2, 0).FormulaR1C1 = FinalDataArray(Loop1, 3) ActiveCell.Offset(0, 1).Select Next Loop1 ' Clear System 7 Linear count Range("H5").Select ActiveCell.Value = 0 End Sub Sub Mod7Subb11_CleanUp() Range("A1").Select End Sub Private EndDate As Integer Private EndDatePrev As Integer Private EndDateText As String Private EndDatePrevText As String Private MonthName1 As String Private MonthName1Prev As String Private MonthName2 As String Private MonthName2Prev As String Private StartDate As Integer Private StartDatePrev As Integer Private StartDateText As String Private StartDatePrevText As String Private TablesWorksheet As String Private TablesWorksheetPrev As String Private TablesWorksheetSave As String Private WeekEndingDate As String Private WeekEndingDatePrev As String Private YearName1 As Integer Private YearName1Prev As Integer Private YearName1Text As String Private YearName1PrevText As String Private YearName2 As Integer Private YearName2Prev As Integer Private YearName2Text As String Private YearName2PrevText As String Sub mod10Sub1_CopyDataMacro() ' This subroutine asks for the weekending date for the ' tables the user wants to create. It then creates a new worksheet ' based on last week's table. It moves all last week's numbers to ' the last week columns and zeroes out this week's numbers, to ' be added manually now, and automatically at a later date. ' NOTE- Some nomenclature clarification: ' The most recent Tables data is always one week old. ' In the comments of this module, "this week's data/Tables" ' refers to that one week old data. "Last week's data/Tables" ' refers to the data/Tables from two weeks ago. Application.ScreenUpdating = False If TablesFlag = 0 Then Exit Sub 'mod10Sub2_Init Mod10Sub3_GetDates mod10Sub4_CreateWorksheet mod10Sub5_TransferData ' mod10Sub6_CleanUp Application.ScreenUpdating = True End Sub Sub mod11Sub2_Init() End Sub Sub mod11Sub3_GetDates() ' Uses the current date (as shown on the computer, so this must be set correctly) ' then automatically calculates last week's week-ending date. Workbooks.Add Columns("A:A").ColumnWidth = 20 Columns("B:B").ColumnWidth = 20 Range("A1").Select ActiveCell.FormulaR1C1 = "=NOW()" Selection.NumberFormat = "ddd" Let TempVar = ActiveCell.Text Range("A2").Select Select Case TempVar Case "Mon" ActiveCell.FormulaR1C1 = "=R[-1]C-1" Case "Tue" ActiveCell.FormulaR1C1 = "=R[-1]C-2" Case "Wed" ActiveCell.FormulaR1C1 = "=R[-1]C-3" Case "Thu" ActiveCell.FormulaR1C1 = "=R[-1]C-4" Case "Fri" ActiveCell.FormulaR1C1 = "=R[-1]C-5" Case "Sat" ActiveCell.FormulaR1C1 = "=R[-1]C-6" Case "Sun" ActiveCell.FormulaR1C1 = "=R[-1]C-7" End Select Range("A2").Select Selection.NumberFormat = "mm/dd/yy" WeekEndingDate = ActiveCell.Text ActiveWorkbook.Saved = True ActiveWindow.Close ' load date into menu Form_WklyRptTables.TextBox_WklyRptTables.Value = WeekEndingDate ' show the menu Form_WklyRptTables.Show ' reload date in case user changed it WeekEndingDate = Form_WklyRptTables.TextBox_WklyRptTables.Value ' Calculate the rest of the various date formats needed for ' starting a new set of Tables. Workbooks.Add Columns("A:C").ColumnWidth = 20 Range("A1:C8").Select Selection.NumberFormat = "mm/dd/yy" Range("C4").Select Selection.Characters.Text = WeekEndingDate Selection.Copy Range("A4").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Calculate start of the week Range("A1").Select ActiveCell.FormulaR1C1 = "=R[3]C-6" Selection.NumberFormat = "dd" StartDate = ActiveCell.Text Selection.NumberFormat = "mmm" MonthName1 = ActiveCell.Text Selection.NumberFormat = "yyyy" YearName1 = ActiveCell.Text ' Calculate end of the week Range("A2").Select ActiveCell.FormulaR1C1 = "=R[-1]C+6" Selection.NumberFormat = "dd" EndDate = ActiveCell.Text Selection.NumberFormat = "mmm" MonthName2 = ActiveCell.Text Selection.NumberFormat = "yyyy" YearName2 = ActiveCell.Text ' Calculate previous week Range("B4").Select ActiveCell.FormulaR1C1 = "=R[0]C[-1]-7" WeekEndingDatePrev = ActiveCell.Text ' Calculate start of previous week Range("B1").Select ActiveCell.FormulaR1C1 = "=R[3]C-6" Selection.NumberFormat = "dd" StartDatePrev = ActiveCell.Text Selection.NumberFormat = "mmm" MonthName1Prev = ActiveCell.Text Selection.NumberFormat = "yyyy" YearName1Prev = ActiveCell.Text ' Calculate end of the previous week Range("B2").Select ActiveCell.FormulaR1C1 = "=R[-1]C+6" Selection.NumberFormat = "dd" EndDatePrev = ActiveCell.Text Selection.NumberFormat = "mmm" MonthName2Prev = ActiveCell.Text Selection.NumberFormat = "yyyy" YearName2Prev = ActiveCell.Text ActiveWorkbook.Saved = True ActiveWindow.Close ' Reassign some variable names, as VBA won't accept integer variable in file name StartDateText = StartDate StartDatePrevText = StartDatePrev EndDateText = EndDate EndDatePrevText = EndDatePrev YearName1Text = YearName1 YearName1PrevText = YearName1Prev YearName2Text = YearName2 YearName2PrevText = YearName2Prev End Sub Sub mod11Sub4_CreateWorksheet() ' Determine name for last week's table worksheet If YearName1Prev = YearName2Prev Then If MonthName1Prev = MonthName2Prev Then ' Same year, same month TablesWorksheetPrev = "Wkly Rpt Tables " + MonthName1Prev + " " + StartDatePrevText + "-" + EndDatePrevText + ", " + YearName1PrevText + ".xls" Else 'Different months TablesWorksheetPrev = "Wkly Rpt Tables " + MonthName1Prev + " " + StartDatePrevText + "-" + MonthName2Prev + " " + EndDatePrevText + ", " + YearName2PrevText + ".xls" End If Else 'Different years, assume different months TablesWorksheetPrev = "Wkly Rpt Tables " + MonthName1Prev + " " + StartDatePrevText + ", " + YearName1PrevText + "-" + MonthName2Prev + " " + EndDatePrevText + ", " + YearName2PrevText + ".xls" End If ' Determine name for this week's table worksheet If YearName1 = YearName2 Then If MonthName1 = MonthName2 Then ' Same year, same month TablesWorksheetSave = "Wkly Rpt Tables " + MonthName1 + " " + StartDateText + "-" + EndDateText + ", " + YearName1Text Else 'Different months TablesWorksheetSave = "Wkly Rpt Tables " + MonthName1 + " " + StartDateText + "-" + MonthName2 + " " + EndDateText + ", " + YearName2Text End If Else 'Different years, assume different months TablesWorksheetSave = "Wkly Rpt Tables " + MonthName1 + " " + StartDateText + ", " + YearName1Text + "-" + MonthName2 + " " + EndDateText + ", " + YearName2Text End If TablesWorksheet = TablesWorksheetSave + ".xls" ' open last weeks Tables Workbook Workbooks.Open Filename:=TablesLocation + TablesWorksheetPrev ' open Tables template Workbooks.Open Filename:=TemplateLocation + m11_Template ' save Tables Workbook Template with this week's Table name ActiveWorkbook.SaveAs Filename:= _ TablesLocation + TablesWorksheet _ , FileFormat:=xlNormal ' Enter this report's ending date Sheets("Date Info").Select Range("A2").Select ActiveCell.FormulaR1C1 = WeekEndingDate ' grab 'beginning of fiscal year' and 'beginning of month' dates ' from last weeks Tables Windows(TablesWorksheetPrev).Activate Sheets("Date Info").Select Range("A5:C5").Select Selection.Copy ' Paste last week's 'beginning of fiscal year' and 'beginning of month' dates ' into the new Tables worksheet Windows(TablesWorksheet).Activate Sheets("Date Info").Select Range("A5:C5").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Update the current month, if necessary ' Range("B110").Select ' ActiveCell.FormulaR1C1 = "7/1/1998 12:00:00 AM" End Sub Sub mod11Sub5_TransferData() ' ============================================= ' Move last week's data to the last week columns of the this week's Table ' ============================================= ' Wkly Message Totals Windows(TablesWorksheetPrev).Activate Sheets("Tables").Select Range("B3:H3").Select Selection.Copy Windows(TablesWorksheet).Activate Sheets("Tables").Select Range("B2:H2").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Downtime will go here ' Windows(TablesWorksheetPrev).Activate ' Range("G5:H11").Select ' Application.CutCopyMode = False ' Selection.Copy ' Windows(TablesWorksheet).Activate ' Range("G15").Select ' Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ ' False, Transpose:=False ' On-Air MCT Count Windows(TablesWorksheetPrev).Activate Range("B22:H22").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B21:H21").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Cab Card Totals (customers) Windows(TablesWorksheetPrev).Activate Range("B32:H32").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B31:H31").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Cab Card Totals (msgs) Windows(TablesWorksheetPrev).Activate Range("B34:H34").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B33:H33").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Weekly Msg Totals from the Total Message Count worksheet TotalMessageWorksheet = m12_Workbook + "Week of " + StartDay + ".xls" Windows(TotalMessageWorksheet).Activate Sheets("Totals").Select Range("B11:H11").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B3:H3").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Peak Date Windows(TotalMessageWorksheet).Activate Range("B20").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("B38").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Selection.NumberFormat = "ddd, mmm dd" ' Peak Daily Totals Windows(TotalMessageWorksheet).Activate Range("B32").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("D38").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Peak Daily Position Polls Windows(TotalMessageWorksheet).Activate Range("C32").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("F38").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Peak Daily Grand Totals Windows(TotalMessageWorksheet).Activate Range("D32").Select Application.CutCopyMode = False Selection.Copy Windows(TablesWorksheet).Activate Range("H38").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False ' Close previous Tables worksheet, then save this week's Tables worksheet 'Windows(TablesWorksheetPrev).Activate 'ActiveWindow.Close Range("A1").Select Windows(TablesWorksheet).Activate ActiveWorkbook.Save End Sub Sub Mod15Sub1_CleanUp() If LapTopFlag = 0 Then With ActiveWindow .Width = 200 .Height = 100 .Top = 100 .Left = 120 End With Else With ActiveWindow .Width = 100 .Height = 50 .Top = 200 .Left = 100 End With End If ActiveWorkbook.Save End Sub Private Sub CheckBox1_Totals_Change() ' If TotalsFlag = 0 Then ' TotalsFlag = 1 ' Else ' TotalsFlag = 0 ' End If ' MsgBox Prompt:=TotalsFlag End Sub Private Sub CheckBox1_Totals_Click() End Sub Private Sub ComboBox_FLP_Change() TempNum = ComboBox_FLP.ListIndex Select Case ComboBox_FLP.ListIndex Case 0 FlpFrom = 0 FlpTo = 0 Case 1 FlpFrom = 1 FlpTo = TotalNumOfSys Case 2 To 12 FlpFrom = TempNum - 1 FlpTo = TempNum - 1 End Select End Sub Private Sub ComboBox_Poll_Change() TempNum = ComboBox_Poll.ListIndex Select Case ComboBox_Poll.ListIndex Case 0 PollFrom = 0 PollTo = 0 Case 1 PollFrom = 1 PollTo = TotalNumOfSys Case 2 To 12 PollFrom = TempNum - 1 PollTo = TempNum - 1 End Select End Sub Private Sub ComboBox_Weekly_Change() TempNum = ComboBox_Weekly.ListIndex Select Case ComboBox_Weekly.ListIndex Case 0 WeekFrom = 0 WeekTo = 0 Case 1 WeekFrom = 1 WeekTo = TotalNumOfSys Case 2 To 12 WeekFrom = TempNum - 1 WeekTo = TempNum - 1 End Select End Sub Private Sub ComButton_Cancel_Click() End End Sub Private Sub ComButton_OK_Click() Form_GraphingMenu.Hide End Sub Private Sub Label5_Click() End Sub Private Sub Lbl_NoDataLabel2_Click() End Sub Private Sub OptButton_Create_Click() PrintFlag = 0 HtmlFlag = 0 End Sub Private Sub OptButton_HTML_Click() HtmlFlag = 1 PrintFlag = 0 End Sub Private Sub OptButton_Print_Click() HtmlFlag = 0 PrintFlag = 1 End Sub Private Sub UserForm_Click() End Sub $$$$$ Shannon’s Macro Code (1st Eaton) $$$ ' Variable Declarations Public ExpensesArray(20, 1) As String Public ExpenseRatesArray(20, 1) As String Public LaborMembersArray(7, 7) As String Public LaborRatesArray(7, 3) As Currency Public GrandTotalArray(9, 1) As String Public MaterialsArray(7, 1) As String Private DataDirectory As String Private DataFilename As String Private DataDirAndFileName As String Private ExpensesYes As String Private FlagUnknownType As Variant Private LaborYes As String Private LoopRows As Variant Private LoopColumns As Variant Private NoMaterials As String Private Range_DoubleTime_Begin As String Private Range_DoubleTime_End As String Private Range_DoubleTimeEng_Begin As String Private Range_DoubleTimeEng_End As String Private Range_Expenses_Begin As String Private Range_Expenses_End As String Private Range_Labor_Begin As String Private Range_Labor_End As String Private Range_LaborEng_Begin As String Private Range_LaborEng_End As String Private Range_LastLaborEnd As String Private Range_TimeAndHalf_Begin As String Private Range_TimeAndHalf_End As String Private Range_TimeAndHalfEng_Begin As String Private Range_TimeAndHalfEng_End As String Private Range_Materials_Begin As String Private Range_Materials_End As String Private TempAddress1 As String Private TempAddress2 As String Private TempRange_1 As String Private TempRange_2 As String Private TempNum1 As Variant Private TempNum2 As Variant Public TempVar1 As String Public TempVar2 As String Private TempVar3 As String Private TempSum As Variant Private TempSumText As String Private WorksheetDirectory As String Private WorksheetFileName As String Sub S01_SubCalls() ' This Excel macro was created to take an Eaton Oracle data export, ' sort it by labor, expenses, and materials, totaling each section ' and then totaling all costs. ' There are brief explanatory comments throughout the code, ' and there are some instructional notes in the last subroutine: S99_Notes. S03_Init S05_Show_Menu S09_Import_Data S11_Delete_AddRates_Sort S13_Determine_Data_Ranges S15_Insert_Formulas S19_Format S20_Save_and_Cleanup End Sub Sub S03_Init() ' Size and Position Macro Worksheet ActiveWindow.WindowState = xlNormal With ActiveWindow .Width = 220 .Height = 115 .Top = 1 .Left = 1 End With ' Do this because Excel isn't clearing variable values from previous runs ExpensesYes = "" FlagUnknownType = "" LaborYes = "" For Loop1 = 1 To 9 GrandTotalArray(Loop1, 1) = "" Next Loop1 Range_DoubleTime_Begin = "" Range_DoubleTime_End = "" Range_DoubleTimeEng_Begin = "" Range_DoubleTimeEng_End = "" Range_Expenses_Begin = "" Range_Expenses_End = "" Range_Labor_Begin = "" Range_Labor_End = "" Range_LaborEng_Begin = "" Range_LaborEng_End = "" Range_LastLaborEnd = "" Range_TimeAndHalf_Begin = "" Range_TimeAndHalf_End = "" Range_TimeAndHalfEng_Begin = "" Range_TimeAndHalfEng_End = "" Range_Materials_Begin = "" Range_Materials_End = "" TempRange_1 = "" TempRange_2 = "" TempVar1 = "" TempVar2 = "" ' Begin loading the user maintained data Sheets("Data").Select DataDirectory = Range("A2").Text DataFilename = Range("A3").Text ' Load the LaborRatesArray Range("D2").Select For TempNum1 = 1 To 3 For TempNum2 = 1 To 7 LaborRatesArray(TempNum2, TempNum1) = Selection.Value ActiveCell.Offset(1, 0).Select Next TempNum2 ActiveCell.Offset(-7, 1).Select Next TempNum1 ' Load the LaborMembersArray Range("I3").Select For TempNum1 = 2 To 7 For TempNum2 = 1 To 7 LaborMembersArray(TempNum2, TempNum1) = Selection.Value ActiveCell.Offset(1, 0).Select Next TempNum2 ActiveCell.Offset(-7, 1).Select Next TempNum1 ' Load the ExpensesArray Range("P2").Select For TempNum1 = 1 To 20 ExpensesArray(TempNum1, 1) = Selection.Value ActiveCell.Offset(1, 0).Select Next TempNum1 ' Load the ExpenseRatesArray Range("Q2").Select For TempNum1 = 1 To 20 ExpenseRatesArray(TempNum1, 1) = Selection.Value ActiveCell.Offset(1, 0).Select Next TempNum1 ' Load the MaterialsArray Range("S2").Select For TempNum1 = 1 To 7 MaterialsArray(TempNum1, 1) = Selection.Value ActiveCell.Offset(1, 0).Select Next TempNum1 Range("C1").Select Sheets("Start Button").Select End Sub Sub S05_Show_Menu() ' Show Data Input form, confirm directory and get file name Form_DataInput.Textbox_Directory.Value = DataDirectory Form_DataInput.TextBox_DataFileName.Value = DataFilename Form_DataInput.Show ' Show form ' Get data directory and data file Name DataDirectory = Form_DataInput.Textbox_Directory.Text DataFilename = Form_DataInput.TextBox_DataFileName.Text ' Define data directory and data file name DataDirAndFileName = DataDirectory + DataFilename ' Define Excel worksheet directory and file name WorksheetFileName = WorksheetDirectory + DataFilename + " Worksheet" End Sub Sub S09_Import_Data() Application.ScreenUpdating = False ' Open Data File Workbooks.OpenText FileName:= _ DataDirAndFileName, _ Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _ Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _ Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _ Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15 _ , 1), Array(16, 1)) ' Size and Position Data Worksheet Window ActiveWindow.WindowState = xlNormal With ActiveWindow .Width = 480 .Height = 180 .Top = 3 .Left = 3 End With End Sub Sub S11_Delete_AddRates_Sort() ' Clear and Delete columns Columns("A:B").Select Selection.Delete Shift:=xlToLeft Columns("J:N").Select Selection.Delete Shift:=xlToLeft Columns("F:H").Select Selection.Delete Shift:=xlToLeft ' Clear EOM column Columns("E:E").Select Selection.ClearContents Selection.NumberFormat = "$#,##0.00" ' Initial Sort Cells.Select Selection.Sort _ Key1:=Range("A2"), Order1:=xlAscending, _ Key2:=Range("B2"), Order2:=xlAscending, _ Key3:=Range("C2"), Order3:=xlAscending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom ' Detail Sort Range("A1").Select Selection.EntireColumn.Insert Range("F1").Select Selection.EntireColumn.Insert ' ================================================================ ' This section goes through each line of the data and assigns the line ' a number, which is then used to do an in depth sort. ' Labor items are assigned numbers between 100-199 ' Expense items are assigned numbers between 200-299 ' Material items are assigned numbers between 300-399 ' ================================================================ Range("B2").Select TempVar1 = Selection.Text TempVar2 = ActiveCell.Offset(0, 2).Value While TempVar1 > "" ' many conditions and cases in this While; Wend comes near the end of this module Select Case TempVar1 Case "Labor" While TempVar1 = "Labor" TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 100 ' set the initial sort code to 100 ' Loops to check for engineers and insert the appropriate standard labor rate For LoopColumns = 2 To 7 ' array columns For LoopRows = 1 To 7 ' array rows ' If this is one of the engineers, change the sort code to 105. If TempVar2 = LaborMembersArray(LoopRows, 2) Then ActiveCell.Offset(0, -1).Value = 105 ElseIf TempVar2 = LaborMembersArray(LoopRows, 3) Then ActiveCell.Offset(0, -1).Value = 105 End If 'If name is in this classification... If TempVar2 = LaborMembersArray(LoopRows, LoopColumns) Then '... Then insert the appropriate labor rate ActiveCell.Offset(0, 4).Value = LaborRatesArray(LoopColumns, 1) ' Note: The LoopColumns variable in the row above is correctly used in the row place ' The rows in the labor classification correspond to the columns in the labor members ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Value TempVar2 = ActiveCell.Offset(0, 2).Value FoundName = 1 Exit For ' found this name, so exit the search loop End If Next LoopRows If FoundName = 1 Then Exit For ' found this name, so exit the search loop Next LoopColumns If FoundName = 0 Then ' didn't find the name, so use the default tech labor rate ActiveCell.Offset(0, 4).Value = LaborRatesArray(1, 1) ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Value TempVar2 = ActiveCell.Offset(0, 2).Value Else FoundName = 0 End If Wend Case "Time and Half" While TempVar1 = "Time and Half" TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 130 'set initial sort code to 130 ' Loops to check for engineers and insert the appropriate time and half labor rate For LoopColumns = 2 To 7 ' array columns For LoopRows = 1 To 7 ' array rows ' If this is one of the engineers, change the sort code to 135. If TempVar2 = LaborMembersArray(LoopRows, 2) Then ActiveCell.Offset(0, -1).Value = 135 ElseIf TempVar2 = LaborMembersArray(LoopRows, 3) Then ActiveCell.Offset(0, -1).Value = 135 End If 'If name is in this classification... If TempVar2 = LaborMembersArray(LoopRows, LoopColumns) Then '... Then insert the appropriate labor rate ActiveCell.Offset(0, 4).Value = LaborRatesArray(LoopColumns, 2) ' Note: The LoopColumns variable in the row above is correctly used in the row place ' The rows in the labor classification correspond to the columns in the labor members ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Value TempVar2 = ActiveCell.Offset(0, 2).Value FoundName = 1 Exit For ' found this name, so exit the search loop End If Next LoopRows If FoundName = 1 Then Exit For ' found this name, so exit the search loop Next LoopColumns If FoundName = 0 Then ' didn't find the name, so use the default tech time and half labor rate ActiveCell.Offset(0, 4).Value = LaborRatesArray(1, 2) ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Value TempVar2 = ActiveCell.Offset(0, 2).Value Else FoundName = 0 End If Wend Case "Double Time" While TempVar1 = "Double Time" TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 160 'set initial sort code to 160 ' Loops to check for engineers and insert the appropriate double time labor rate For LoopColumns = 2 To 7 ' array columns For LoopRows = 1 To 7 ' array rows ' If this is one of the engineers, change the sort code to 165. If TempVar2 = LaborMembersArray(LoopRows, 2) Then ActiveCell.Offset(0, -1).Value = 165 ElseIf TempVar2 = LaborMembersArray(LoopRows, 3) Then ActiveCell.Offset(0, -1).Value = 165 End If ' If name is in this classification... If TempVar2 = LaborMembersArray(LoopRows, LoopColumns) Then ' ...Then insert the appropriate labor rate ActiveCell.Offset(0, 4).Value = LaborRatesArray(LoopColumns, 3) ' Note: The LoopColumns variable in the row above is correctly used in the row place ' The rows in the labor classification correspond to the columns in the labor members ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Value TempVar2 = ActiveCell.Offset(0, 2).Value FoundName = 1 Exit For ' found this name, so exit the search loop End If Next LoopRows If FoundName = 1 Then Exit For ' found this name, so exit the search loop Next LoopColumns If FoundName = 0 Then ' didn't find the name, so use the default tech double time labor rate ActiveCell.Offset(0, 4).Value = LaborRatesArray(1, 3) ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Value TempVar2 = ActiveCell.Offset(0, 2).Value Else FoundName = 0 End If Wend ' ================================================================ ' Delete Time and Half Premium & Double Time Premium Case "Time and Half Premium" While TempVar1 = "Time and Half Premium" Selection.EntireRow.Delete TempVar1 = ActiveCell.Text Wend Case "Double Time Premium" While TempVar1 = "Double Time Premium" Selection.EntireRow.Delete TempVar1 = ActiveCell.Text Wend ' ================================================================ ' Expenses: Case ExpensesArray(1, 1) While TempVar1 = ExpensesArray(1, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(1, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 200 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(2, 1) While TempVar1 = ExpensesArray(2, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(2, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 205 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(3, 1) While TempVar1 = ExpensesArray(3, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(3, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 210 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(4, 1) While TempVar1 = ExpensesArray(4, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(4, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 215 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(5, 1) While TempVar1 = ExpensesArray(5, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(5, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 220 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(6, 1) While TempVar1 = ExpensesArray(6, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(6, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 225 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(7, 1) While TempVar1 = ExpensesArray(7, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(7, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 230 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(8, 1) While TempVar1 = ExpensesArray(8, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(8, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 235 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(9, 1) While TempVar1 = ExpensesArray(9, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(9, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 240 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(10, 1) While TempVar1 = ExpensesArray(10, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(10, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 245 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(11, 1) While TempVar1 = ExpensesArray(11, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(11, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 250 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(12, 1) While TempVar1 = ExpensesArray(12, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(12, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 255 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(13, 1) While TempVar1 = ExpensesArray(13, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(13, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 260 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(14, 1) While TempVar1 = ExpensesArray(14, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(14, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 265 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(15, 1) While TempVar1 = ExpensesArray(15, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(15, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 270 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(16, 1) While TempVar1 = ExpensesArray(16, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(16, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 275 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(17, 1) While TempVar1 = ExpensesArray(17, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(17, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 280 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(18, 1) While TempVar1 = ExpensesArray(18, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(18, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 285 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(19, 1) While TempVar1 = ExpensesArray(19, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(19, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 290 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case ExpensesArray(20, 1) While TempVar1 = ExpensesArray(20, 1) ActiveCell.Offset(0, 4).Value = ExpenseRatesArray(20, 1) TempRange_1 = ActiveCell.Offset(0, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 5).Formula = "=SUM(" & TempRange_1 & " * " & TempRange_2 & ")" ActiveCell.Offset(0, -1).Value = 295 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend ' ================================================================ Case MaterialsArray(1, 1) While TempVar1 = MaterialsArray(1, 1) ActiveCell.Offset(0, -1).Value = 300 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case MaterialsArray(2, 1) While TempVar1 = MaterialsArray(2, 1) ActiveCell.Offset(0, -1).Value = 305 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case MaterialsArray(3, 1) While TempVar1 = MaterialsArray(3, 1) ActiveCell.Offset(0, -1).Value = 310 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case MaterialsArray(4, 1) While TempVar1 = MaterialsArray(4, 1) ActiveCell.Offset(0, -1).Value = 315 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case MaterialsArray(5, 1) While TempVar1 = MaterialsArray(5, 1) ActiveCell.Offset(0, -1).Value = 320 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case MaterialsArray(6, 1) While TempVar1 = MaterialsArray(6, 1) ActiveCell.Offset(0, -1).Value = 325 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend Case MaterialsArray(7, 1) While TempVar1 = MaterialsArray(7, 1) ActiveCell.Offset(0, -1).Value = 330 ActiveCell.Offset(1, 0).Select TempVar1 = ActiveCell.Text Wend ' ================================================================ Case Else ActiveCell.Offset(0, -1).Value = 1000 ActiveCell.Offset(1, 0).Select End Select ' ================================================================ TempVar1 = Selection.Text TempVar2 = ActiveCell.Offset(0, 2).Value Wend ' this is the Wend that closes the While used near the beginning of this module ' Add end of data marker ActiveCell.Offset(0, -1).Value = 9999 Cells.Select 'do a second sort (first key = sort code, second key = date, third key = employee names) Selection.Sort _ Key1:=Range("A2"), Order1:=xlAscending, _ Key2:=Range("C2"), Order2:=xlAscending, _ Key3:=Range("D2"), Order3:=xlAscending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom ' Add a row for Title info Range("A1").Select Selection.EntireRow.Insert End Sub Sub S13_Determine_Data_Ranges() ' Find Beginning of Headers, Insert Rows, Determine Data Ranges (for totals) Range("A3").Select TempNum1 = Selection.Value ' *********************************************************************** While TempNum1 < 9999 Select Case TempNum1 Case 1000 'unknown type If FlagUnknownType = "" Then FlagUnknownType = "1" TempAddress1 = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False) TempAddress2 = ActiveCell.Offset(11, 0).Address(RowAbsolute:=False, ColumnAbsolute:=False) Range(TempAddress1, TempAddress2).Select Selection.EntireRow.Insert Range(TempAddress2).Offset(-3, 1).Select ActiveCell.FormulaR1C1 = "Macro could not classify the unknown types below." ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = "[To fix this and get an accurate Grand Total," ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = " these unknown expense types" ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = " need to be added to the data worksheet.]" ActiveCell.Offset(2, -1).Select TempNum1 = ActiveCell.Value Else ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value End If Case 100 'standard labor Range_Labor_Begin = ActiveCell.Offset(0, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) While TempNum1 = 100 ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value Wend Range_Labor_End = ActiveCell.Offset(-1, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) Case 105 'engineer's standard labor Selection.EntireRow.Insert Selection.EntireRow.Insert Range_LaborEng_Begin = ActiveCell.Offset(2, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(1, 0).Select While TempNum1 < 111 ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value Wend Range_LaborEng_End = ActiveCell.Offset(-1, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) Case 130 'time and half labor Selection.EntireRow.Insert Selection.EntireRow.Insert Range_TimeAndHalf_Begin = ActiveCell.Offset(2, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(1, 0).Select While TempNum1 = 130 ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value Wend Range_TimeAndHalf_End = ActiveCell.Offset(-1, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) Case 135 'engineers time and half labor Selection.EntireRow.Insert Selection.EntireRow.Insert Range_TimeAndHalfEng_Begin = ActiveCell.Offset(2, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(1, 0).Select While TempNum1 < 141 ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value Wend Range_TimeAndHalfEng_End = ActiveCell.Offset(-1, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) Case 160 'doubletime labor Selection.EntireRow.Insert Selection.EntireRow.Insert Range_DoubleTime_Begin = ActiveCell.Offset(2, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(1, 0).Select While TempNum1 = 160 ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value Wend Range_DoubleTime_End = ActiveCell.Offset(-1, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) Case 165 'engineers doubletime labor Selection.EntireRow.Insert Selection.EntireRow.Insert Range_DoubleTimeEng_Begin = ActiveCell.Offset(2, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(1, 0).Select While TempNum1 < 171 ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value Wend Range_DoubleTimeEng_End = ActiveCell.Offset(-1, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) Case Is < 300 And TempNum1 > 199 'expenses Selection.EntireRow.Insert Selection.EntireRow.Insert Selection.EntireRow.Insert ExpensesYes = "Yes" Range_Expenses_Begin = ActiveCell.Offset(3, 6).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(2, 0).Select While TempNum1 < 300 ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value Wend Range_Expenses_End = ActiveCell.Offset(-1, 6).Address(RowAbsolute:=False, ColumnAbsolute:=False) Case Is < 400 And TempNum1 > 299 'materials purchased Selection.EntireRow.Insert Selection.EntireRow.Insert If ExpensesYes = "" Then Selection.EntireRow.Insert 'no expense, add another blank row Range_Materials_Begin = ActiveCell.Offset(2, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(1, 0).Select While TempNum1 < 400 ActiveCell.Offset(1, 0).Select TempNum1 = ActiveCell.Value Wend Range_Materials_End = ActiveCell.Offset(-1, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) End Select Wend If FlagUnknownType = "1" Then MsgBox ("The macro found at least one expense type it can't classify. Grand Totals will not be accurate.") End If End Sub Sub S15_Insert_Formulas() ' Total the Labor and insert formula If Range_Labor_Begin = "" Then ' in case there is no Labor Else Range(Range_Labor_End).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & Range_Labor_Begin & ":" & Range_Labor_End & ")" 'sum hours TempRange_1 = Range(Range_Labor_Begin).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = Range(Range_Labor_End).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 2).Formula = "=SUM(" & TempRange_1 & ":" & TempRange_2 & ")" 'sum dollars ActiveCell.Offset(0, 2).Select Range_LastLaborEnd = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) GrandTotalArray(1, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) End If ' Total the Engineer's Labor and insert formula If Range_LaborEng_Begin = "" Then ' in case there is no Engineers Labor Else Range(Range_LaborEng_End).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & Range_LaborEng_Begin & ":" & Range_LaborEng_End & ")" 'sum hours TempRange_1 = Range(Range_LaborEng_Begin).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = Range(Range_LaborEng_End).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 2).Formula = "=SUM(" & TempRange_1 & ":" & TempRange_2 & ")" 'sum dollars ActiveCell.Offset(0, 2).Select Range_LastLaborEnd = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) GrandTotalArray(2, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) End If ' Total the Time and Half and insert formula If Range_TimeAndHalf_Begin = "" Then ' in case there is no Time and Half Labor Else Range(Range_TimeAndHalf_End).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & Range_TimeAndHalf_Begin & ":" & Range_TimeAndHalf_End & ")" 'sum hours TempRange_1 = Range(Range_TimeAndHalf_Begin).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = Range(Range_TimeAndHalf_End).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 2).Formula = "=SUM(" & TempRange_1 & ":" & TempRange_2 & ")" 'sum dollars ActiveCell.Offset(0, 2).Select Range_LastLaborEnd = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) GrandTotalArray(3, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) End If ' Total the Engineer's Time and Half and insert formula If Range_TimeAndHalfEng_Begin = "" Then ' in case there is no Engineers Time and Half Labor Else Range(Range_TimeAndHalfEng_End).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & Range_TimeAndHalfEng_Begin & ":" & Range_TimeAndHalfEng_End & ")" 'sum hours TempRange_1 = Range(Range_TimeAndHalfEng_Begin).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = Range(Range_TimeAndHalfEng_End).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 2).Formula = "=SUM(" & TempRange_1 & ":" & TempRange_2 & ")" 'sum dollars ActiveCell.Offset(0, 2).Select Range_LastLaborEnd = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) GrandTotalArray(4, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) End If ' Total the Double Time and insert formula If Range_DoubleTime_Begin = "" Then ' in case there is no Doubletime Labor Else Range(Range_DoubleTime_End).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & Range_DoubleTime_Begin & ":" & Range_DoubleTime_End & ")" 'sum hours TempRange_1 = Range(Range_DoubleTime_Begin).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = Range(Range_DoubleTime_End).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 2).Formula = "=SUM(" & TempRange_1 & ":" & TempRange_2 & ")" 'sum dollars ActiveCell.Offset(0, 2).Select Range_LastLaborEnd = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) GrandTotalArray(5, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) End If ' Total the Engineer's Double Time and insert formula If Range_DoubleTimeEng_Begin = "" Then ' in case there is no Engineers Doubletime Labor Else Range(Range_DoubleTimeEng_End).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & Range_DoubleTimeEng_Begin & ":" & Range_DoubleTimeEng_End & ")" 'sum hours TempRange_1 = Range(Range_DoubleTimeEng_Begin).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) TempRange_2 = Range(Range_DoubleTimeEng_End).Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) ActiveCell.Offset(0, 2).Formula = "=SUM(" & TempRange_1 & ":" & TempRange_2 & ")" 'sum dollars ActiveCell.Offset(0, 2).Select Range_LastLaborEnd = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) GrandTotalArray(6, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) End If ' Total All the Labor If Range_Labor_Begin > "" Then Range(Range_Labor_Begin).Select LaborYes = "yes" ElseIf Range_LaborEng_Begin > "" Then Range(Range_LaborEng_Begin).Select LaborYes = "yes" End If If LaborYes = "yes" Then Range(Range_LastLaborEnd).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & GrandTotalArray(1, 1) & "," & GrandTotalArray(2, 1) & "," & GrandTotalArray(3, 1) & "," & GrandTotalArray(4, 1) & "," & GrandTotalArray(5, 1) & "," & GrandTotalArray(6, 1) & ")" GrandTotalArray(7, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) ' total of all Labor ActiveCell.Offset(0, -1).Select ActiveCell.FormulaR1C1 = "TOTAL LABOR =" With Selection .HorizontalAlignment = xlRight End With ElseIf Range_Expenses_Begin > "" Then Range(Range_Expenses_Begin).Select ActiveCell.Offset(0, 2).Select TempRange_1 = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) ElseIf Range_Materials_Begin > "" Then Range(Range_Materials_Begin).Select ActiveCell.Offset(0, 2).Select TempRange_1 = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) End If ' Total Expenses and insert formula If Range_Expenses_Begin = "" Then Else Range(Range_Expenses_End).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & Range_Expenses_Begin & ":" & Range_Expenses_End & ")" GrandTotalArray(8, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) ' total of all Expenses ActiveCell.Offset(0, -1).Select ActiveCell.FormulaR1C1 = "TOTAL EXPENSES =" With Selection .HorizontalAlignment = xlRight End With End If ' Total Materials and insert formula If Range_Materials_Begin = "" Then Else Range(Range_Materials_End).Select ActiveCell.Offset(1, 0).Select ActiveCell.Formula = "=SUM(" & Range_Materials_Begin & ":" & Range_Materials_End & ")" ActiveCell.Offset(0, 2).Select ActiveCell.Formula = "=SUM(" & Range_Materials_Begin & ":" & Range_Materials_End & ")" GrandTotalArray(9, 1) = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False) ' total of all Materials ActiveCell.Offset(0, -1).Select ActiveCell.FormulaR1C1 = "TOTAL MATERIALS =" With Selection .HorizontalAlignment = xlRight End With End If ' Insert Formula to total all costs ActiveCell.Offset(2, 1).Select ActiveCell.Formula = "=SUM(" & GrandTotalArray(7, 1) & "," & GrandTotalArray(8, 1) & "," & GrandTotalArray(9, 1) & ")" ActiveCell.Offset(0, -3).Select ActiveCell.FormulaR1C1 = "TOTAL COST" ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = "TOTAL MARINE BILLED" ActiveCell.Offset(1, 0).Select ActiveCell.FormulaR1C1 = "TOTAL DOC BILLED" End Sub Sub S19_Format() ' Remove the sorting column Columns("A:A").Select Selection.Delete Shift:=xlToLeft ' Set Font and Size Cells.Select With Selection.Font .Name = "Arial" .Size = 7 End With ' Format Column Labels Range("E2").Select ActiveCell.FormulaR1C1 = "Rates" ActiveCell.Offset(0, 1).FormulaR1C1 = "Totals" Range("A2:G2").Select Selection.Font.Bold = True Selection.Font.Underline = xlUnderlineStyleSingle ' Repeat Column Labels on each page Range("A1").Select With ActiveSheet.PageSetup .PrintTitleRows = "$1:$2" End With ' Freeze Column headers so they're visible throughout the worksheet Range("A3").Select ActiveWindow.FreezePanes = True ' Set Margins With ActiveSheet.PageSetup .LeftMargin = Application.InchesToPoints(0.5) .RightMargin = Application.InchesToPoints(0.5) .TopMargin = Application.InchesToPoints(0.5) .BottomMargin = Application.InchesToPoints(0.75) .HeaderMargin = Application.InchesToPoints(0.5) .FooterMargin = Application.InchesToPoints(0.5) .Orientation = xlLandscape End With ' Make worksheet more legible Range("B2").Select With Selection .HorizontalAlignment = xlRight End With Range("D2:F2").Select With Selection .HorizontalAlignment = xlCenter End With Range("C2").Select Selection.EntireColumn.Insert Columns("C:C").ColumnWidth = 3 ' Size columns Columns("A:G").EntireColumn.AutoFit Columns("H:H").Select Selection.ColumnWidth = 50 ' Insert and Format Title Range("A1").Select ActiveCell.FormulaR1C1 = DataFilename Range("A1:H1").Select Selection.Font.Bold = True With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .MergeCells = True End With ' Add Footer With ActiveSheet.PageSetup .RightFooter = "&7Eaton Corp. Confidential &A Page &P" End With End Sub Sub S20_Save_and_Cleanup() Range("A2").Select ' Save the file ' ActiveWorkbook.SaveAs FileName:= _ ' WorksheetFileName _ ' , FileFormat:=xlNormal ' Fake the save ' ActiveWorkbook.Saved = True Application.ScreenUpdating = True ActiveWindow.WindowState = xlMaximized MsgBox ("The macro has completed.") End Sub Sub S99_Notes() ' Notes on this macro (03-11-02, by Rick Struble) ' To change the defaults that show in the popup dialog box: ' go to the "Data" worksheet and change values in cells A2 or A3 ' To add or change expense line items: ' go to the "Data" worksheet and change values in cells P2 through P21 ' To add or make changes to the labor rates: ' go to the "Data" worksheet and change values in cells D2 through F8 ' To add or make changes to the labor classification members: ' go to the "Data" worksheet and change values in cells I3 through N9 End Sub $$$$$ Microsoft Word Macros $$$ =================================================== Sub Buffy_add_highlight() Selection.TypeText Text:="

" Selection.Find.ClearFormatting With Selection.Find .Text = "/P" .Forward = True End With Selection.Find.Execute Selection.MoveLeft Unit:=wdCharacter, Count:=2 Selection.TypeText Text:="

" Selection.EndKey Unit:=wdLine, Extend:=wdExtend Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.Find.ClearFormatting With Selection.Find .Text = "