Hello
I am new to the forum and was wondering if somebody could help me
We have just been upgraded from Office 2003 to Office 2010. I have some VBA that works fine in Excel 2003 that runs from a command button and opens up a confirm files form where I can choose a MS Project 2010 file which should generate an excel extract. However it hangs after selecting the project file while in the background generating 2 temporary workbooks.
I include all the code but am unsure how to fix it. Thanks
Option Explicit
Const TRACKER_CHANGEORREMOVE_TEMPLATE_WORKSHEET = "CHANGE OR REMOVE TEMPLATE"
Const TRACKER_ADD_TEMPLATE_WORKSHEET = "ADD TEMPLATE"
Const TRACKER_GUIDANCE_TEMPLATE_WORKSHEET = "GUIDANCE TEMPLATE"
Const TRACKER_GUIDANCE_TEMPLATE_2_WORKSHEET = "GUIDANCE TEMPLATE 2"
Const TRACKER_DEFAULTS_WORKSHEET = "DEFAULTS"
Const TRACKER_CODES_WORKSHEET = "KEY TO CODES"
Const MAX_TABNAME_LENGTH = 10
Const MAX_PROGRESSCOMMENT_LEN = 100
Const DATE_FORMAT = "dd/mm/yyyy"
Const ERRCODE_FILE_NOT_FOUND = 9001
Const ERRCODE_FILE_WRONG_TYPE = 9002
Public TRACKER_HEADER_ROW
Public TRACKER_START_ROW
Public SHOW_SUMMARY_TASKS As Boolean
Public LOGFILE As Integer
Public LEVEL As Integer
Public dToday As Date
Public WINDOW_START As Date
Public WINDOW_FINISH As Date
Public SORT_COL_NAME As String
Public HISTORIC_WEEKS As Integer
Public FORECAST_WEEKS As Integer
Public DEFAULT_PATH As String
Sub Start()
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim sFilesList
TRACKER_HEADER_ROW = Worksheets(TRACKER_CHANGEORREMOVE_TEMPLATE_WORKSHEET).Range("HeaderRow").row
TRACKER_START_ROW = TRACKER_HEADER_ROW + 1
HISTORIC_WEEKS = Worksheets(TRACKER_DEFAULTS_WORKSHEET).Range("Historic")
FORECAST_WEEKS = Worksheets(TRACKER_DEFAULTS_WORKSHEET).Range("Forecast")
' Initialise
LEVEL = 4
SHOW_SUMMARY_TASKS = False
dToday = Date
SORT_COL_NAME = "ProjectID"
WINDOW_START = "01/01/10"
WINDOW_FINISH = Date - Weekday(Date) + 2 + (FORECAST_WEEKS * 7)
Close ' Close any open output files
'Unload frmConfirmFiles ' Unload the Confirm Files form in case its already loaded
Unload frmCalendar2 ' Unload the Calendar form in case its already loaded
frmConfirmFiles.Show ' Open the Confirm Files form
' Upon returning from the confirm files form, call the generate trackers function, retrieving the list of files from the form
Call GenerateTrackers(frmConfirmFiles.RetrieveList)
Exit Sub
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in Start() subroutine."
End
End Sub
Public Sub SelectFiles(ByRef sFileList As Variant, ByVal sDefaultPath As String)
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim fs
Dim lngCount As Long
Set fs = CreateObject("Scripting.FileSystemObject")
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
If fs.FolderExists(sDefaultPath) Then
.InitialFileName = sDefaultPath
Else
.InitialFileName = ThisWorkbook.Path
End If
.Title = "Select MS Project files to generate trackers (hold ctrl jet for multiselect)."
.Filters.Clear
.Filters.Add "MS Project (.mpp,.mpt)", "*.mpp; *.mpt", 1
.Show
' capture paths of each file selected
ReDim sFileList(.SelectedItems.Count)
For lngCount = 1 To .SelectedItems.Count
sFileList(lngCount - 1) = .SelectedItems(lngCount)
Next lngCount
End With
Exit Sub
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in SelectFiles() subroutine."
End
End Sub
Sub GenerateTrackers(ByVal sFileList)
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
' Define variables
Dim i As Integer 'counter used for iterating lists
Dim j As Integer
Dim iFile As Integer 'counter used for iterating files
Dim iErr As Integer 'error code returned from called functions
Dim iNumFiles As Integer
Dim sMsg As String
Dim fs
Dim wTracker As Worksheet
Dim wTemplate As Worksheet
Dim wAddTemplate As Worksheet
Dim wGuidanceTemplate As Worksheet
Dim wGuidanceTemplate2 As Worksheet
Dim wKeytocodes As Worksheet
Dim wDefaults As Worksheet
Dim wbTracker As Workbook
Dim wbTemplate As Workbook
Dim sName As String
Dim dProgressInterval As Double
Dim appProj As MSProject.Application
Dim appExcel As Excel.Application
' Dim bIncludeTask As Boolean
Dim pProj As Project
Dim sProj As String
Dim tTask
Dim iTask As Integer
Dim cCell As Range
Dim iRow As Integer
Dim iStartRow As Integer
Dim iNumRows As Integer
Dim wbTmp1 As Workbook ' the tmp workbook that collates all the data
Dim wbTmp2 As Workbook ' the individual tmp workbooks that are used to export from each project file
Dim sTmp1Excel As String
Dim sTmp2Excel As String
Dim sVal As String
Dim sCurrVal As String
Dim iNumGroups As Integer
Dim iSortColNum As Integer
Dim sProgress As String
Dim bProjectAppAlreadyOpen As Boolean
Dim bProjectFileAlreadyOpen As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
' Initialise Progress Bars
frmProgress.Show
frmProgress.pbProgressOverall = 0
frmProgress.pbProgressCurrent = 0
frmProgress.lbProgressOverall = "Preparing to process tracker ..."
frmProgress.lbProgressCurrent = ""
' Initialise variables
Set fs = CreateObject("Scripting.FileSystemObject")
sMsg = ""
Set wbTemplate = ThisWorkbook
Set wTemplate = wbTemplate.Worksheets(TRACKER_CHANGEORREMOVE_TEMPLATE_WORKSHEET)
Set wAddTemplate = wbTemplate.Worksheets(TRACKER_ADD_TEMPLATE_WORKSHEET)
Set wGuidanceTemplate = wbTemplate.Worksheets(TRACKER_GUIDANCE_TEMPLATE_WORKSHEET)
Set wGuidanceTemplate2 = wbTemplate.Worksheets(TRACKER_GUIDANCE_TEMPLATE_2_WORKSHEET)
Set wDefaults = wbTemplate.Worksheets(TRACKER_DEFAULTS_WORKSHEET)
Set wKeytocodes = wbTemplate.Worksheets(TRACKER_CODES_WORKSHEET)
' Create a MSProject Instance
Set appProj = CreateObject("MSProject.Application")
If appProj Is Nothing Then
MsgBox "MS Project could not be located on this machine.", vbCritical + vbOKOnly, "Not Found"
End
End If
appProj.DisplayAlerts = False
' Create a seperate MSExcel Instance
Set appExcel = Application 'CreateObject("Excel.Application")
If appExcel Is Nothing Then
MsgBox "Could not create MS Excel temp file on this machine.", vbCritical + vbOKOnly, "Not Found"
End
End If
' The newly created instance of excel should not be visible
'appExcel.Visible = True
' Turn off alerts and screen updating
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wbTracker = appExcel.Workbooks.Add
' Close all open text files
Close
' Open Error File
LOGFILE = FreeFile
If DEBUG_MODE Then Close #LOGFILE
If DEBUG_MODE Then Open Me.Path & "\" & Me.Name & ".err.txt" For Output As #LOGFILE
' Identify number of items in list
iNumFiles = UBound(sFileList) - LBound(sFileList)
' Find which column number is the group/sort column
iSortColNum = wTemplate.Range(SORT_COL_NAME).Column
' Generate names for the 2 temp excel files
sTmp1Excel = Me.Path & "/" & fs.getbasename(Me.Name) & "_tmp1_" & Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")
sTmp2Excel = Me.Path & "/" & fs.getbasename(Me.Name) & "_tmp2_" & Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")
' Initialise Tracker spreadsheet row pointer
iRow = 1
' Create the overall temp excel file - used to collate all of the data from all project files
Set wbTmp1 = appExcel.Workbooks.Add
'wbTmp1.SaveAs Filename:=sTmp1Excel
dProgressInterval = 99 / iNumFiles
frmProgress.pbProgressOverall = 10
frmProgress.pbProgressCurrent = 0
frmProgress.lbProgressOverall = "Processing MS Project files ..."
frmProgress.Show
' Iterate through the list of files
For iFile = 0 To iNumFiles - 1
' Update progress form to detail which file is being processed
sProgress = "Processing File (" & iFile + 1 & "/" & iNumFiles & "): " & fs.getfilename(sFileList(iFile))
If Len(sProgress) > MAX_PROGRESSCOMMENT_LEN Then sProgress = Left(sProgress, MAX_PROGRESSCOMMENT_LEN) & "..."
frmProgress.lbProgressCurrent = sProgress
frmProgress.Repaint
' Write to log file
If DEBUG_MODE Then Write #LOGFILE, Date & ";Processing File: " & sFileList(iFile)
' only process MS Project Files (it should only be possible to process MSP files due to the filter applied in the "Open" dialog
' but this is included just in case
If Not (LCase(fs.GetExtensionName(sFileList(iFile))) = "mpp" Or LCase(fs.GetExtensionName(sFileList(iFile))) = "mpt") Then
If DEBUG_MODE Then Write #LOGFILE, Date & "," & Time & "Cannot process file (does not appear to be a MS Project file): " & sFileList(iFile)
iErr = ERRCODE_FILE_WRONG_TYPE
ElseIf Not fs.fileExists(sFileList(iFile)) Then
If DEBUG_MODE Then Write #LOGFILE, Date & "," & Time & "Cannot find file: " & sFileList(iFile)
iErr = ERRCODE_FILE_NOT_FOUND
Else
' Open project file
If Not ProjectFileIsOpen(appProj, CStr(sFileList(iFile))) Then
appProj.FileOpen (sFileList(iFile))
bProjectFileAlreadyOpen = False
Else
bProjectFileAlreadyOpen = True
End If
Set pProj = appProj.Projects(fs.getbasename(sFileList(iFile)))
' Create a filter to based on user specified criteria
Call pProj.Application.FilterEdit("CPPCNFilter", True, True, True, , , "Number11", , "is less than or equal to", LEVEL, "And", False, SHOW_SUMMARY_TASKS)
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "Number11", "is greater than or equal to", 1, "And", False, SHOW_SUMMARY_TASKS)
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "Summary", "equals", "No", "And", False, SHOW_SUMMARY_TASKS)
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "Start", "is less than or equal to", WINDOW_FINISH, "And", False, SHOW_SUMMARY_TASKS)
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "Finish", "is greater than or equal to", WINDOW_START, "And", False, SHOW_SUMMARY_TASKS)
If frmConfirmFiles.optCompleteNo = True Then
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "% Complete", "does not equal", "100%", "And", False, SHOW_SUMMARY_TASKS)
End If
' Create an export map based on the TEMPLATE worksheet (ignoring columns that are to be left blank in the tracker)
i = 1
For Each cCell In wTemplate.Range("HeaderRow").Rows(-1).Cells
If Not cCell.Text = "BLANK" Then
If i = 1 Then
pProj.Application.MapEdit FieldName:=cCell.Text, Name:="CPExportMap", Create:=True, OverwriteExisting:=True, DataCategory:=0, CategoryEnabled:=True, TableName:="Task_Table1", ExportFilter:="CPPCNFilter", ImportMethod:=0, HeaderRow:=False, AssignmentData:=False, TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False, IncludeImage:=False
Else
pProj.Application.MapEdit FieldName:=cCell.Text, Name:="CPExportMap", DataCategory:=0
End If
End If
i = i + 1
Next
' Export the data into a new temporary workbook based on the filter and export map specified above
pProj.SaveAs Name:=sTmp2Excel, Format:=pjXLS, Map:="CPExportMap"
' Read the data from new temporary workbook and append to the master temp workbook
Set wbTmp2 = appExcel.Workbooks.Open(sTmp2Excel)
With wbTmp2.Sheets(1)
j = 1
While Not .Cells(j, 1).Text = ""
j = j + 1
Wend
With .Range(.Cells(1, 1), .Cells(j, 30))
'.Columns(wTracker.Range("HeaderRow").Columns.Count + 1) = pProj.Name
'.Columns(wTracker.Range("HeaderRow").Columns.Count + 1) = pProj.BuiltinDocumentProperties("Manager")
.Copy (wbTmp1.Sheets(1).Cells(iRow, 1))
End With
iRow = iRow + j - 1
End With
' If the project file was NOT already open then close it
If Not bProjectFileAlreadyOpen Then
pProj.Application.FileClose (pjDoNotSave)
End If
' Delete the the new temporary workbook
wbTmp2.Close SaveChanges:=False
Set wbTmp2 = Nothing
fs.deletefile (sTmp2Excel)
End If
frmProgress.pbProgressCurrent = frmProgress.pbProgressCurrent + dProgressInterval
Next 'iFile
'Exit sub-routine if there are no active milestones on the plan
If wbTmp1.Sheets(1).Cells(1, 1) = "" Then
wbTmp1.Close SaveChanges:=False
wbTracker.Close SaveChanges:=False
Set wbTmp1 = Nothing
MsgBox "There are no milestones that fit the specified criteria for this Tracker." & Chr(10) & Chr(10) & "Common causes of this error include:" & Chr(10) & "1) Reporting periods that are too short;" & Chr(10) & "2) Generating trackers from completed plans (with the option to exclude completed milestones selected);" & Chr(10) & "3) Generating trackers from plans with no milestone levels (1, 2 or 3) assigned." & Chr(10) & Chr(10) & "Please review the options that you selected and try again."
End
End If
' Set the variable holding the total number of tasks pulled out of the various project files.
iNumRows = iRow
' Process the
dProgressInterval = 99 / iNumRows
frmProgress.pbProgressOverall = 50
frmProgress.pbProgressCurrent = 0
frmProgress.lbProgressOverall = "Generating tracker ..."
frmProgress.lbProgressCurrent = ""
frmProgress.Repaint
' Sort the data depending on how the user has chosen to group it (i.e. project, subproject or strand)
With wbTmp1.Sheets(1)
With .Range(.Cells(1, 1), .Cells(iNumRows, 30))
' Go through the tracker template and identify where the blank rows are and insert them into appropriate
' position the temp excel sheet so that when the content is pasted into tracker it is in the right shape.
i = 1
For Each cCell In wTemplate.Range("HeaderRow").Rows(-1).Cells
If cCell.Text = "BLANK" Then
.Columns(i).Insert
End If
i = i + 1
Next
' sort the data extracted into the temp excel sheet based on the column the user wished to group by
.Sort Key1:=.Cells(1, iSortColNum), Order1:=xlAscending
' iterate through the temp excel sheet
iRow = 1
iStartRow = 1
iNumGroups = 0
sCurrVal = .Cells(iRow, iSortColNum).Text
While iRow <= iNumRows
sVal = .Cells(iRow, iSortColNum).Text
If (Not sVal = sCurrVal) Or iRow >= iNumRows Then
' Update current progress text to show the group we are processing
sProgress = "Processing Group: " & sVal
If Len(sProgress) > MAX_PROGRESSCOMMENT_LEN Then sProgress = Left(sProgress, MAX_PROGRESSCOMMENT_LEN) & "..."
frmProgress.lbProgressCurrent = sProgress
frmProgress.Repaint
'create a new sheet in the template, and copy from the temp file to the new sheet
wTemplate.Copy before:=wbTracker.Worksheets("Sheet1")
Set wTracker = wbTracker.Worksheets(wbTracker.Worksheets("Sheet1").Index - 1)
wTracker.Visible = xlSheetVisible
' copy this section from tmp excel to the newly created tracker worksheet
.Range(.Rows(iStartRow), .Rows(iRow - 1)).Copy (wTracker.Cells(TRACKER_START_ROW, 1))
' Populate the date fields on the tab
wTracker.Range("DatePrepared").Value = Format(Date, DATE_FORMAT)
wTracker.Range("PeriodStart").Value = Format(WINDOW_START, DATE_FORMAT)
wTracker.Range("PeriodEnd").Value = Format(WINDOW_FINISH, DATE_FORMAT)
wTracker.Range("GroupName").Value = sCurrVal
wTracker.Range("GroupType").Value = SORT_COL_NAME
If sCurrVal = "" Then
Call NameSheet(wTracker, "No " & SORT_COL_NAME)
Else
Call NameSheet(wTracker, sCurrVal)
End If
With wTracker
' Paste the formats from the first row of the tracker to all of the rows
wTemplate.Rows(TRACKER_START_ROW).Copy
.Range(.Rows(TRACKER_START_ROW), .Rows(TRACKER_START_ROW + (iRow - iStartRow) - 1)).PasteSpecial (xlPasteFormats)
' Paste the cell validation (drop down list) to all rows
.Cells(TRACKER_START_ROW, .Range("NewStatus").Column).Copy
.Range(.Cells(TRACKER_START_ROW, .Range("NewStatus").Column), .Cells(TRACKER_START_ROW + (iRow - iStartRow) - 1, .Range("NewStatus").Column)).PasteSpecial xlPasteAll
' Paste the cell validation (drop down list) to all rows
.Cells(TRACKER_START_ROW, .Range("Remove").Column).Copy
.Range(.Cells(TRACKER_START_ROW, .Range("Remove").Column), .Cells(TRACKER_START_ROW + (iRow - iStartRow) - 1, .Range("Remove").Column)).PasteSpecial xlPasteAll
' Clear the Field Names that are present on the template
.Range("HeaderRow").Rows(-1).Value = ""
' Recalculate the Milestone Count formula based on the size of the table.
.Range("MilestoneCount").Formula = "=counta(" & .Range(.Cells(TRACKER_START_ROW, .Range("UniqueID").Column), .Cells(TRACKER_START_ROW + (iRow - iStartRow) + 1, .Range("UniqueID").Column)).Address & ")"
End With
'Resize Rows
wTracker.Rows("14:750").EntireRow.AutoFit
' Remove the copy selection box that is left behind from pasting formats
appExcel.CutCopyMode = False
' Select top left cell of sheet.
wTracker.Cells(1, 1).Select
' Repaste the key from the template back into the template.
wDefaults.Range("Key").Copy (wTracker.Cells(TRACKER_START_ROW + (iRow - iStartRow) + 3, wTracker.Range("Remove").Column))
' Switch on Autofilter
wTracker.Range("HeaderRow").AutoFilter
' Set the indicators for identifying next group
sCurrVal = sVal
iStartRow = iRow
iNumGroups = iNumGroups + 1
End If
iRow = iRow + 1
' Update the current (lower) progress bar for each row on the sheet that is processed.
frmProgress.pbProgressCurrent = frmProgress.pbProgressCurrent + dProgressInterval
Wend
End With
End With
frmProgress.pbProgressOverall = 100
frmProgress.pbProgressCurrent = 100
frmProgress.lbProgressOverall = "Tidying up..."
frmProgress.lbProgressCurrent = ""
' Paste a copy of the Add Milestones Template to the end of the tracker
wAddTemplate.Copy after:=wbTracker.Worksheets(wbTracker.Worksheets.Count)
wbTracker.Worksheets(wAddTemplate.Name).Visible = True
wbTracker.Worksheets(wAddTemplate.Name).Tab.Color = 13434828
wbTracker.Worksheets(wAddTemplate.Name).Name = "New & Amend"
wbTracker.Worksheets(1).Activate
' Paste a copy of the Guidance Template to the end of the tracker
wGuidanceTemplate.Copy after:=wbTracker.Worksheets(wbTracker.Worksheets.Count)
wbTracker.Worksheets(wGuidanceTemplate.Name).Visible = True
wbTracker.Worksheets(wGuidanceTemplate.Name).Tab.ColorIndex = 39
wbTracker.Worksheets(wGuidanceTemplate.Name).Name = "Tracker Guidance"
wbTracker.Worksheets(1).Activate
' Paste a copy of the Guidance Template 2 to the end of the tracker
wGuidanceTemplate2.Copy after:=wbTracker.Worksheets(wbTracker.Worksheets.Count)
wbTracker.Worksheets(wGuidanceTemplate2.Name).Visible = True
wbTracker.Worksheets(wGuidanceTemplate2.Name).Tab.ColorIndex = 39
wbTracker.Worksheets(wGuidanceTemplate2.Name).Name = "Plan Guidance"
wbTracker.Worksheets(1).Activate
' Paste a copy of the Key to Codes Template to the end of the tracker
wKeytocodes.Copy after:=wbTracker.Worksheets(wbTracker.Worksheets.Count)
wbTracker.Worksheets(wKeytocodes.Name).Visible = True
wbTracker.Worksheets(wKeytocodes.Name).Tab.ColorIndex = 39
wbTracker.Worksheets(wKeytocodes.Name).Name = "Key to Codes"
wbTracker.Worksheets(1).Activate
' Delete the default worksheets that were created when new workbook was created.
For Each wTracker In wbTracker.Worksheets
If wTracker.Name = "Sheet1" Or wTracker.Name = "Sheet2" Or wTracker.Name = "Sheet3" Then
wTracker.Delete
End If
Next
' Close temp excel file without saving
wbTmp1.Close SaveChanges:=False
' Unload progress form and confirmfiles form
Unload frmProgress
Unload frmConfirmFiles
' Release objects
Set wbTmp1 = Nothing
Set appExcel = Nothing
Set appProj = Nothing
Set fs = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in GenerateTrackers() subroutine."
End
End Sub
Function ProjectFileIsOpen(p As MSProject.Application, sName As String) As Boolean
Dim i As Integer
ProjectFileIsOpen = False
i = 1
While i <= p.Projects.Count And Not ProjectFileIsOpen
If p.Projects(i).FullName = sName Then ProjectFileIsOpen = True
i = i + 1
Wend
Exit Function
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in ProjectFileIsOpen() subroutine."
End
End Function
Function SheetExists(sName As String) As Boolean
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim wSheet
SheetExists = False
For Each wSheet In ThisWorkbook.Worksheets
If wSheet.Name = sName Then SheetExists = True
Next
Exit Function
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in SheetExists() function."
End
End Function
Sub NameSheet(wSheet As Worksheet, sName As String)
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim iCounter As Integer
iCounter = 0
While SheetExists(sName)
iCounter = iCounter + 1
sName = sName & " " & iCounter
Wend
wSheet.Name = sName
Exit Sub
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in NameSheet() function."
End
End Sub
Function SortList(ByRef sOldList, bUniqueSort As Boolean) As Variant
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim sNewList
Dim iOldCount As Integer
Dim iNewCount As Integer
Dim i As Integer
Dim k As Integer
Dim j As Integer
iOldCount = UBound(sOldList)
ReDim sNewList(iOldCount) As String
For i = 0 To iOldCount - 1
sNewList(i) = ""
Next
iNewCount = 0
For i = 0 To iOldCount - 1
j = 0
While j < iNewCount And sNewList(j) < sOldList(i)
j = j + 1
Wend
' if reached end of list
If sNewList(j) > sOldList(i) Or (sNewList(j) = sOldList(i) And Not bUniqueSort) Then
' insert into new list before j by moving all subsequent items up a place and then inserting at pos j
For k = iNewCount To j + 1 Step -1
sNewList(k) = sNewList(k - 1)
Next
sNewList(j) = sOldList(i)
iNewCount = iNewCount + 1
ElseIf j >= iNewCount Then
sNewList(j) = sOldList(i)
iNewCount = iNewCount + 1
End If
Next
SortList = sNewList
Exit Function
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in SortList() function."
End
End Function
I am new to the forum and was wondering if somebody could help me
We have just been upgraded from Office 2003 to Office 2010. I have some VBA that works fine in Excel 2003 that runs from a command button and opens up a confirm files form where I can choose a MS Project 2010 file which should generate an excel extract. However it hangs after selecting the project file while in the background generating 2 temporary workbooks.
I include all the code but am unsure how to fix it. Thanks
Option Explicit
Const TRACKER_CHANGEORREMOVE_TEMPLATE_WORKSHEET = "CHANGE OR REMOVE TEMPLATE"
Const TRACKER_ADD_TEMPLATE_WORKSHEET = "ADD TEMPLATE"
Const TRACKER_GUIDANCE_TEMPLATE_WORKSHEET = "GUIDANCE TEMPLATE"
Const TRACKER_GUIDANCE_TEMPLATE_2_WORKSHEET = "GUIDANCE TEMPLATE 2"
Const TRACKER_DEFAULTS_WORKSHEET = "DEFAULTS"
Const TRACKER_CODES_WORKSHEET = "KEY TO CODES"
Const MAX_TABNAME_LENGTH = 10
Const MAX_PROGRESSCOMMENT_LEN = 100
Const DATE_FORMAT = "dd/mm/yyyy"
Const ERRCODE_FILE_NOT_FOUND = 9001
Const ERRCODE_FILE_WRONG_TYPE = 9002
Public TRACKER_HEADER_ROW
Public TRACKER_START_ROW
Public SHOW_SUMMARY_TASKS As Boolean
Public LOGFILE As Integer
Public LEVEL As Integer
Public dToday As Date
Public WINDOW_START As Date
Public WINDOW_FINISH As Date
Public SORT_COL_NAME As String
Public HISTORIC_WEEKS As Integer
Public FORECAST_WEEKS As Integer
Public DEFAULT_PATH As String
Sub Start()
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim sFilesList
TRACKER_HEADER_ROW = Worksheets(TRACKER_CHANGEORREMOVE_TEMPLATE_WORKSHEET).Range("HeaderRow").row
TRACKER_START_ROW = TRACKER_HEADER_ROW + 1
HISTORIC_WEEKS = Worksheets(TRACKER_DEFAULTS_WORKSHEET).Range("Historic")
FORECAST_WEEKS = Worksheets(TRACKER_DEFAULTS_WORKSHEET).Range("Forecast")
' Initialise
LEVEL = 4
SHOW_SUMMARY_TASKS = False
dToday = Date
SORT_COL_NAME = "ProjectID"
WINDOW_START = "01/01/10"
WINDOW_FINISH = Date - Weekday(Date) + 2 + (FORECAST_WEEKS * 7)
Close ' Close any open output files
'Unload frmConfirmFiles ' Unload the Confirm Files form in case its already loaded
Unload frmCalendar2 ' Unload the Calendar form in case its already loaded
frmConfirmFiles.Show ' Open the Confirm Files form
' Upon returning from the confirm files form, call the generate trackers function, retrieving the list of files from the form
Call GenerateTrackers(frmConfirmFiles.RetrieveList)
Exit Sub
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in Start() subroutine."
End
End Sub
Public Sub SelectFiles(ByRef sFileList As Variant, ByVal sDefaultPath As String)
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim fs
Dim lngCount As Long
Set fs = CreateObject("Scripting.FileSystemObject")
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
If fs.FolderExists(sDefaultPath) Then
.InitialFileName = sDefaultPath
Else
.InitialFileName = ThisWorkbook.Path
End If
.Title = "Select MS Project files to generate trackers (hold ctrl jet for multiselect)."
.Filters.Clear
.Filters.Add "MS Project (.mpp,.mpt)", "*.mpp; *.mpt", 1
.Show
' capture paths of each file selected
ReDim sFileList(.SelectedItems.Count)
For lngCount = 1 To .SelectedItems.Count
sFileList(lngCount - 1) = .SelectedItems(lngCount)
Next lngCount
End With
Exit Sub
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in SelectFiles() subroutine."
End
End Sub
Sub GenerateTrackers(ByVal sFileList)
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
' Define variables
Dim i As Integer 'counter used for iterating lists
Dim j As Integer
Dim iFile As Integer 'counter used for iterating files
Dim iErr As Integer 'error code returned from called functions
Dim iNumFiles As Integer
Dim sMsg As String
Dim fs
Dim wTracker As Worksheet
Dim wTemplate As Worksheet
Dim wAddTemplate As Worksheet
Dim wGuidanceTemplate As Worksheet
Dim wGuidanceTemplate2 As Worksheet
Dim wKeytocodes As Worksheet
Dim wDefaults As Worksheet
Dim wbTracker As Workbook
Dim wbTemplate As Workbook
Dim sName As String
Dim dProgressInterval As Double
Dim appProj As MSProject.Application
Dim appExcel As Excel.Application
' Dim bIncludeTask As Boolean
Dim pProj As Project
Dim sProj As String
Dim tTask
Dim iTask As Integer
Dim cCell As Range
Dim iRow As Integer
Dim iStartRow As Integer
Dim iNumRows As Integer
Dim wbTmp1 As Workbook ' the tmp workbook that collates all the data
Dim wbTmp2 As Workbook ' the individual tmp workbooks that are used to export from each project file
Dim sTmp1Excel As String
Dim sTmp2Excel As String
Dim sVal As String
Dim sCurrVal As String
Dim iNumGroups As Integer
Dim iSortColNum As Integer
Dim sProgress As String
Dim bProjectAppAlreadyOpen As Boolean
Dim bProjectFileAlreadyOpen As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
' Initialise Progress Bars
frmProgress.Show
frmProgress.pbProgressOverall = 0
frmProgress.pbProgressCurrent = 0
frmProgress.lbProgressOverall = "Preparing to process tracker ..."
frmProgress.lbProgressCurrent = ""
' Initialise variables
Set fs = CreateObject("Scripting.FileSystemObject")
sMsg = ""
Set wbTemplate = ThisWorkbook
Set wTemplate = wbTemplate.Worksheets(TRACKER_CHANGEORREMOVE_TEMPLATE_WORKSHEET)
Set wAddTemplate = wbTemplate.Worksheets(TRACKER_ADD_TEMPLATE_WORKSHEET)
Set wGuidanceTemplate = wbTemplate.Worksheets(TRACKER_GUIDANCE_TEMPLATE_WORKSHEET)
Set wGuidanceTemplate2 = wbTemplate.Worksheets(TRACKER_GUIDANCE_TEMPLATE_2_WORKSHEET)
Set wDefaults = wbTemplate.Worksheets(TRACKER_DEFAULTS_WORKSHEET)
Set wKeytocodes = wbTemplate.Worksheets(TRACKER_CODES_WORKSHEET)
' Create a MSProject Instance
Set appProj = CreateObject("MSProject.Application")
If appProj Is Nothing Then
MsgBox "MS Project could not be located on this machine.", vbCritical + vbOKOnly, "Not Found"
End
End If
appProj.DisplayAlerts = False
' Create a seperate MSExcel Instance
Set appExcel = Application 'CreateObject("Excel.Application")
If appExcel Is Nothing Then
MsgBox "Could not create MS Excel temp file on this machine.", vbCritical + vbOKOnly, "Not Found"
End
End If
' The newly created instance of excel should not be visible
'appExcel.Visible = True
' Turn off alerts and screen updating
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wbTracker = appExcel.Workbooks.Add
' Close all open text files
Close
' Open Error File
LOGFILE = FreeFile
If DEBUG_MODE Then Close #LOGFILE
If DEBUG_MODE Then Open Me.Path & "\" & Me.Name & ".err.txt" For Output As #LOGFILE
' Identify number of items in list
iNumFiles = UBound(sFileList) - LBound(sFileList)
' Find which column number is the group/sort column
iSortColNum = wTemplate.Range(SORT_COL_NAME).Column
' Generate names for the 2 temp excel files
sTmp1Excel = Me.Path & "/" & fs.getbasename(Me.Name) & "_tmp1_" & Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")
sTmp2Excel = Me.Path & "/" & fs.getbasename(Me.Name) & "_tmp2_" & Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")
' Initialise Tracker spreadsheet row pointer
iRow = 1
' Create the overall temp excel file - used to collate all of the data from all project files
Set wbTmp1 = appExcel.Workbooks.Add
'wbTmp1.SaveAs Filename:=sTmp1Excel
dProgressInterval = 99 / iNumFiles
frmProgress.pbProgressOverall = 10
frmProgress.pbProgressCurrent = 0
frmProgress.lbProgressOverall = "Processing MS Project files ..."
frmProgress.Show
' Iterate through the list of files
For iFile = 0 To iNumFiles - 1
' Update progress form to detail which file is being processed
sProgress = "Processing File (" & iFile + 1 & "/" & iNumFiles & "): " & fs.getfilename(sFileList(iFile))
If Len(sProgress) > MAX_PROGRESSCOMMENT_LEN Then sProgress = Left(sProgress, MAX_PROGRESSCOMMENT_LEN) & "..."
frmProgress.lbProgressCurrent = sProgress
frmProgress.Repaint
' Write to log file
If DEBUG_MODE Then Write #LOGFILE, Date & ";Processing File: " & sFileList(iFile)
' only process MS Project Files (it should only be possible to process MSP files due to the filter applied in the "Open" dialog
' but this is included just in case
If Not (LCase(fs.GetExtensionName(sFileList(iFile))) = "mpp" Or LCase(fs.GetExtensionName(sFileList(iFile))) = "mpt") Then
If DEBUG_MODE Then Write #LOGFILE, Date & "," & Time & "Cannot process file (does not appear to be a MS Project file): " & sFileList(iFile)
iErr = ERRCODE_FILE_WRONG_TYPE
ElseIf Not fs.fileExists(sFileList(iFile)) Then
If DEBUG_MODE Then Write #LOGFILE, Date & "," & Time & "Cannot find file: " & sFileList(iFile)
iErr = ERRCODE_FILE_NOT_FOUND
Else
' Open project file
If Not ProjectFileIsOpen(appProj, CStr(sFileList(iFile))) Then
appProj.FileOpen (sFileList(iFile))
bProjectFileAlreadyOpen = False
Else
bProjectFileAlreadyOpen = True
End If
Set pProj = appProj.Projects(fs.getbasename(sFileList(iFile)))
' Create a filter to based on user specified criteria
Call pProj.Application.FilterEdit("CPPCNFilter", True, True, True, , , "Number11", , "is less than or equal to", LEVEL, "And", False, SHOW_SUMMARY_TASKS)
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "Number11", "is greater than or equal to", 1, "And", False, SHOW_SUMMARY_TASKS)
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "Summary", "equals", "No", "And", False, SHOW_SUMMARY_TASKS)
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "Start", "is less than or equal to", WINDOW_FINISH, "And", False, SHOW_SUMMARY_TASKS)
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "Finish", "is greater than or equal to", WINDOW_START, "And", False, SHOW_SUMMARY_TASKS)
If frmConfirmFiles.optCompleteNo = True Then
Call pProj.Application.FilterEdit("CPPCNFilter", True, False, False, , , , "% Complete", "does not equal", "100%", "And", False, SHOW_SUMMARY_TASKS)
End If
' Create an export map based on the TEMPLATE worksheet (ignoring columns that are to be left blank in the tracker)
i = 1
For Each cCell In wTemplate.Range("HeaderRow").Rows(-1).Cells
If Not cCell.Text = "BLANK" Then
If i = 1 Then
pProj.Application.MapEdit FieldName:=cCell.Text, Name:="CPExportMap", Create:=True, OverwriteExisting:=True, DataCategory:=0, CategoryEnabled:=True, TableName:="Task_Table1", ExportFilter:="CPPCNFilter", ImportMethod:=0, HeaderRow:=False, AssignmentData:=False, TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False, IncludeImage:=False
Else
pProj.Application.MapEdit FieldName:=cCell.Text, Name:="CPExportMap", DataCategory:=0
End If
End If
i = i + 1
Next
' Export the data into a new temporary workbook based on the filter and export map specified above
pProj.SaveAs Name:=sTmp2Excel, Format:=pjXLS, Map:="CPExportMap"
' Read the data from new temporary workbook and append to the master temp workbook
Set wbTmp2 = appExcel.Workbooks.Open(sTmp2Excel)
With wbTmp2.Sheets(1)
j = 1
While Not .Cells(j, 1).Text = ""
j = j + 1
Wend
With .Range(.Cells(1, 1), .Cells(j, 30))
'.Columns(wTracker.Range("HeaderRow").Columns.Count + 1) = pProj.Name
'.Columns(wTracker.Range("HeaderRow").Columns.Count + 1) = pProj.BuiltinDocumentProperties("Manager")
.Copy (wbTmp1.Sheets(1).Cells(iRow, 1))
End With
iRow = iRow + j - 1
End With
' If the project file was NOT already open then close it
If Not bProjectFileAlreadyOpen Then
pProj.Application.FileClose (pjDoNotSave)
End If
' Delete the the new temporary workbook
wbTmp2.Close SaveChanges:=False
Set wbTmp2 = Nothing
fs.deletefile (sTmp2Excel)
End If
frmProgress.pbProgressCurrent = frmProgress.pbProgressCurrent + dProgressInterval
Next 'iFile
'Exit sub-routine if there are no active milestones on the plan
If wbTmp1.Sheets(1).Cells(1, 1) = "" Then
wbTmp1.Close SaveChanges:=False
wbTracker.Close SaveChanges:=False
Set wbTmp1 = Nothing
MsgBox "There are no milestones that fit the specified criteria for this Tracker." & Chr(10) & Chr(10) & "Common causes of this error include:" & Chr(10) & "1) Reporting periods that are too short;" & Chr(10) & "2) Generating trackers from completed plans (with the option to exclude completed milestones selected);" & Chr(10) & "3) Generating trackers from plans with no milestone levels (1, 2 or 3) assigned." & Chr(10) & Chr(10) & "Please review the options that you selected and try again."
End
End If
' Set the variable holding the total number of tasks pulled out of the various project files.
iNumRows = iRow
' Process the
dProgressInterval = 99 / iNumRows
frmProgress.pbProgressOverall = 50
frmProgress.pbProgressCurrent = 0
frmProgress.lbProgressOverall = "Generating tracker ..."
frmProgress.lbProgressCurrent = ""
frmProgress.Repaint
' Sort the data depending on how the user has chosen to group it (i.e. project, subproject or strand)
With wbTmp1.Sheets(1)
With .Range(.Cells(1, 1), .Cells(iNumRows, 30))
' Go through the tracker template and identify where the blank rows are and insert them into appropriate
' position the temp excel sheet so that when the content is pasted into tracker it is in the right shape.
i = 1
For Each cCell In wTemplate.Range("HeaderRow").Rows(-1).Cells
If cCell.Text = "BLANK" Then
.Columns(i).Insert
End If
i = i + 1
Next
' sort the data extracted into the temp excel sheet based on the column the user wished to group by
.Sort Key1:=.Cells(1, iSortColNum), Order1:=xlAscending
' iterate through the temp excel sheet
iRow = 1
iStartRow = 1
iNumGroups = 0
sCurrVal = .Cells(iRow, iSortColNum).Text
While iRow <= iNumRows
sVal = .Cells(iRow, iSortColNum).Text
If (Not sVal = sCurrVal) Or iRow >= iNumRows Then
' Update current progress text to show the group we are processing
sProgress = "Processing Group: " & sVal
If Len(sProgress) > MAX_PROGRESSCOMMENT_LEN Then sProgress = Left(sProgress, MAX_PROGRESSCOMMENT_LEN) & "..."
frmProgress.lbProgressCurrent = sProgress
frmProgress.Repaint
'create a new sheet in the template, and copy from the temp file to the new sheet
wTemplate.Copy before:=wbTracker.Worksheets("Sheet1")
Set wTracker = wbTracker.Worksheets(wbTracker.Worksheets("Sheet1").Index - 1)
wTracker.Visible = xlSheetVisible
' copy this section from tmp excel to the newly created tracker worksheet
.Range(.Rows(iStartRow), .Rows(iRow - 1)).Copy (wTracker.Cells(TRACKER_START_ROW, 1))
' Populate the date fields on the tab
wTracker.Range("DatePrepared").Value = Format(Date, DATE_FORMAT)
wTracker.Range("PeriodStart").Value = Format(WINDOW_START, DATE_FORMAT)
wTracker.Range("PeriodEnd").Value = Format(WINDOW_FINISH, DATE_FORMAT)
wTracker.Range("GroupName").Value = sCurrVal
wTracker.Range("GroupType").Value = SORT_COL_NAME
If sCurrVal = "" Then
Call NameSheet(wTracker, "No " & SORT_COL_NAME)
Else
Call NameSheet(wTracker, sCurrVal)
End If
With wTracker
' Paste the formats from the first row of the tracker to all of the rows
wTemplate.Rows(TRACKER_START_ROW).Copy
.Range(.Rows(TRACKER_START_ROW), .Rows(TRACKER_START_ROW + (iRow - iStartRow) - 1)).PasteSpecial (xlPasteFormats)
' Paste the cell validation (drop down list) to all rows
.Cells(TRACKER_START_ROW, .Range("NewStatus").Column).Copy
.Range(.Cells(TRACKER_START_ROW, .Range("NewStatus").Column), .Cells(TRACKER_START_ROW + (iRow - iStartRow) - 1, .Range("NewStatus").Column)).PasteSpecial xlPasteAll
' Paste the cell validation (drop down list) to all rows
.Cells(TRACKER_START_ROW, .Range("Remove").Column).Copy
.Range(.Cells(TRACKER_START_ROW, .Range("Remove").Column), .Cells(TRACKER_START_ROW + (iRow - iStartRow) - 1, .Range("Remove").Column)).PasteSpecial xlPasteAll
' Clear the Field Names that are present on the template
.Range("HeaderRow").Rows(-1).Value = ""
' Recalculate the Milestone Count formula based on the size of the table.
.Range("MilestoneCount").Formula = "=counta(" & .Range(.Cells(TRACKER_START_ROW, .Range("UniqueID").Column), .Cells(TRACKER_START_ROW + (iRow - iStartRow) + 1, .Range("UniqueID").Column)).Address & ")"
End With
'Resize Rows
wTracker.Rows("14:750").EntireRow.AutoFit
' Remove the copy selection box that is left behind from pasting formats
appExcel.CutCopyMode = False
' Select top left cell of sheet.
wTracker.Cells(1, 1).Select
' Repaste the key from the template back into the template.
wDefaults.Range("Key").Copy (wTracker.Cells(TRACKER_START_ROW + (iRow - iStartRow) + 3, wTracker.Range("Remove").Column))
' Switch on Autofilter
wTracker.Range("HeaderRow").AutoFilter
' Set the indicators for identifying next group
sCurrVal = sVal
iStartRow = iRow
iNumGroups = iNumGroups + 1
End If
iRow = iRow + 1
' Update the current (lower) progress bar for each row on the sheet that is processed.
frmProgress.pbProgressCurrent = frmProgress.pbProgressCurrent + dProgressInterval
Wend
End With
End With
frmProgress.pbProgressOverall = 100
frmProgress.pbProgressCurrent = 100
frmProgress.lbProgressOverall = "Tidying up..."
frmProgress.lbProgressCurrent = ""
' Paste a copy of the Add Milestones Template to the end of the tracker
wAddTemplate.Copy after:=wbTracker.Worksheets(wbTracker.Worksheets.Count)
wbTracker.Worksheets(wAddTemplate.Name).Visible = True
wbTracker.Worksheets(wAddTemplate.Name).Tab.Color = 13434828
wbTracker.Worksheets(wAddTemplate.Name).Name = "New & Amend"
wbTracker.Worksheets(1).Activate
' Paste a copy of the Guidance Template to the end of the tracker
wGuidanceTemplate.Copy after:=wbTracker.Worksheets(wbTracker.Worksheets.Count)
wbTracker.Worksheets(wGuidanceTemplate.Name).Visible = True
wbTracker.Worksheets(wGuidanceTemplate.Name).Tab.ColorIndex = 39
wbTracker.Worksheets(wGuidanceTemplate.Name).Name = "Tracker Guidance"
wbTracker.Worksheets(1).Activate
' Paste a copy of the Guidance Template 2 to the end of the tracker
wGuidanceTemplate2.Copy after:=wbTracker.Worksheets(wbTracker.Worksheets.Count)
wbTracker.Worksheets(wGuidanceTemplate2.Name).Visible = True
wbTracker.Worksheets(wGuidanceTemplate2.Name).Tab.ColorIndex = 39
wbTracker.Worksheets(wGuidanceTemplate2.Name).Name = "Plan Guidance"
wbTracker.Worksheets(1).Activate
' Paste a copy of the Key to Codes Template to the end of the tracker
wKeytocodes.Copy after:=wbTracker.Worksheets(wbTracker.Worksheets.Count)
wbTracker.Worksheets(wKeytocodes.Name).Visible = True
wbTracker.Worksheets(wKeytocodes.Name).Tab.ColorIndex = 39
wbTracker.Worksheets(wKeytocodes.Name).Name = "Key to Codes"
wbTracker.Worksheets(1).Activate
' Delete the default worksheets that were created when new workbook was created.
For Each wTracker In wbTracker.Worksheets
If wTracker.Name = "Sheet1" Or wTracker.Name = "Sheet2" Or wTracker.Name = "Sheet3" Then
wTracker.Delete
End If
Next
' Close temp excel file without saving
wbTmp1.Close SaveChanges:=False
' Unload progress form and confirmfiles form
Unload frmProgress
Unload frmConfirmFiles
' Release objects
Set wbTmp1 = Nothing
Set appExcel = Nothing
Set appProj = Nothing
Set fs = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in GenerateTrackers() subroutine."
End
End Sub
Function ProjectFileIsOpen(p As MSProject.Application, sName As String) As Boolean
Dim i As Integer
ProjectFileIsOpen = False
i = 1
While i <= p.Projects.Count And Not ProjectFileIsOpen
If p.Projects(i).FullName = sName Then ProjectFileIsOpen = True
i = i + 1
Wend
Exit Function
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in ProjectFileIsOpen() subroutine."
End
End Function
Function SheetExists(sName As String) As Boolean
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim wSheet
SheetExists = False
For Each wSheet In ThisWorkbook.Worksheets
If wSheet.Name = sName Then SheetExists = True
Next
Exit Function
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in SheetExists() function."
End
End Function
Sub NameSheet(wSheet As Worksheet, sName As String)
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim iCounter As Integer
iCounter = 0
While SheetExists(sName)
iCounter = iCounter + 1
sName = sName & " " & iCounter
Wend
wSheet.Name = sName
Exit Sub
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in NameSheet() function."
End
End Sub
Function SortList(ByRef sOldList, bUniqueSort As Boolean) As Variant
If Not DEBUG_MODE Then On Error GoTo ERR_HANDLE
Dim sNewList
Dim iOldCount As Integer
Dim iNewCount As Integer
Dim i As Integer
Dim k As Integer
Dim j As Integer
iOldCount = UBound(sOldList)
ReDim sNewList(iOldCount) As String
For i = 0 To iOldCount - 1
sNewList(i) = ""
Next
iNewCount = 0
For i = 0 To iOldCount - 1
j = 0
While j < iNewCount And sNewList(j) < sOldList(i)
j = j + 1
Wend
' if reached end of list
If sNewList(j) > sOldList(i) Or (sNewList(j) = sOldList(i) And Not bUniqueSort) Then
' insert into new list before j by moving all subsequent items up a place and then inserting at pos j
For k = iNewCount To j + 1 Step -1
sNewList(k) = sNewList(k - 1)
Next
sNewList(j) = sOldList(i)
iNewCount = iNewCount + 1
ElseIf j >= iNewCount Then
sNewList(j) = sOldList(i)
iNewCount = iNewCount + 1
End If
Next
SortList = sNewList
Exit Function
ERR_HANDLE:
MsgBox "Error: " & Err & " " & Error & " in SortList() function."
End
End Function
