Pick a folder and consolidate workbooks

Question

I'm trying to create a simple way for current & future (non VBA literate) employees to accomplish some of the tasks I've struggled with. The first being Parsing cells containing Line Feed Characters.

When reports are produced from Workday, sometimes they have to be produced for each item separately, and you end up with a folder like this -

Within each book is a sheet of the same name, but cut off at 31 characters (the maximum for sheet names).

I'd like to enable the user to simply select the folder containing the books and consolidate, rename and alphabetize the sheets.

All in the same module (the CONST) used later, main sub:

Option Explicit
Public Const COMPUTER As String = "C:\"

Public Sub CombineWorkbooks()

    Dim myPath As String
    myPath = UserInputDirectory(COMPUTER)
    If myPath = vbNullString Then
        MsgBox "You cancelled the operation", vbCritical
        Exit Sub
    End If

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False


    Dim destinationWorkbook As Workbook
    Set destinationWorkbook = Workbooks.Add
    destinationWorkbook.Sheets("Sheet2").Delete
    destinationWorkbook.Sheets("Sheet3").Delete

    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet

    Dim strFilename As String
    strFilename = Dir(myPath & "\*.xls", vbNormal)
    If Len(strFilename) = 0 Then Exit Sub

    Do Until strFilename = ""
        Set sourceWorkbook = Workbooks.Open(Filename:=myPath & "\" & strFilename)
        Set sourceWorksheet = sourceWorkbook.Worksheets(1)
        RenameSheet sourceWorksheet
        sourceWorksheet.Copy After:=destinationWorkbook.Worksheets(destinationWorkbook.Worksheets.Count)
        sourceWorkbook.Close False
        strFilename = Dir()
    Loop
    destinationWorkbook.Sheets("Sheet1").Delete

    Application.DisplayAlerts = True
    Application.EnableEvents = True

    AlphebetizeSheets destinationWorkbook
End Sub

And the supporting cast

Private Sub AlphebetizeSheets(ByVal myBook As Workbook)
    Dim i As Long
    Dim j As Long

    For i = 1 To myBook.Worksheets.Count
        For j = i To myBook.Worksheets.Count
            If UCase(myBook.Sheets(j).Name) < UCase(myBook.Sheets(i).Name) Then
                  myBook.Sheets(j).Move before:=Sheets(i)
             End If
        Next
    Next
    Application.ScreenUpdating = True
    Application.GetSaveAsFilename
End Sub

Private Sub RenameSheet(ByVal targetSheet As Worksheet)
    Dim myParser As Long
    Dim newName As String
    myParser = InStr(1, targetSheet.Name, "(")
    If myParser > 0 Then
        newName = Trim(Left(targetSheet.Name, myParser - 1))
        targetSheet.Name = newName
    End If
End Sub

Private Function UserInputDirectory(ByVal baseDirectory As String) As String
    Dim userFolder As FileDialog
    Dim directoryName As String
    MsgBox "Please select the folder the workbooks are in"
    Set userFolder = Application.FileDialog(msoFileDialogFolderPicker)
    With userFolder
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = baseDirectory
        If .Show <> -1 Then GoTo FolderPicked
        directoryName = .SelectedItems(1)
    End With
FolderPicked:
    UserInputDirectory = directoryName
    Set userFolder = Nothing
End Function

I'm sort of worried that there's too much going on in the CombineWorkbooks() sub and that I've missed some errors that may need to be handled.

Answer 1

You've got a spelling mistake; it's "Alphabetize".

Private Sub AlphebetizeSheets(ByVal myBook As Workbook)
    Dim i As Long
    Dim j As Long

    For i = 1 To myBook.Worksheets.Count
        For j = i To myBook.Worksheets.Count
            If UCase(myBook.Sheets(j).Name) < UCase(myBook.Sheets(i).Name) Then
                  myBook.Sheets(j).Move before:=Sheets(i)
             End If
        Next
    Next
    Application.ScreenUpdating = True
    Application.GetSaveAsFilename
End Sub

I thought this is the sort of thing that has been made before...

https://msdn.microsoft.com/en-us/library/office/ff195025.aspx

And it has. But they do it the same way, with two small differences:

• They don't compare the sheets with themselves via starting the second for loop at i+1
• They don't check the last sheet by stopping i at myBook.Worksheets.Count - 1

Which I guess saves a few comparisons. You've got a weird sorting algorithm here too, a version of selection and insertion sort... which seems to have some flaws, in my opinion.

8 3 2 6 4 5 1 7
checks 8, 3, moves 3
3 8 2 6 4 5 1 7
checks 2, moves 2
2 3 8 6 4 5 1 7
checks 6, 4, 5, 1 moves 1
1 2 3 8 6 4 5 7
checks 7, next iteration
compares 2 to 3, 8, 6, 4, 5, 7, next iteration
compares 3 to 8, 6, 4, 5, 7, next iteration
compares 8 to 6, moves 6
1 2 3 6 8 4 5 7
compares 6 to 8, 4 moves 4
1 2 3 4 6 8 5 7
compares 4 to 5, 7, next iteration
compares 6 to 8, 5 moves 5
1 2 3 4 5 6 8 7
compares 5 to 7, next iteration
compares 6 to 8, 7, next iteration
compares 8 to 7, moves 7
1 2 3 4 5 6 7 8, next iteration and end.

The problem with this sort is that it compares items[i] with items[i+1] even although on the previous iteration, multiple shifts happened. Take a look at the start:

8 3 2 6 4 5 1 7
checks 8, 3, moves 3
3 8 2 6 4 5 1 7
checks 2, moves 2
2 3 8 6 4 5 1 7
checks 6, 4, 5, 1 moves 1
1 2 3 8 6 4 5 7
checks 7, next iteration

After that, it should know that 2 > 1, 3 > 2, and 8 > 3 so it should skip those.

So instead of

compares 2 to 3, 8, 6, 4, 5, 7, next iteration

it should be

compares 2 to 6, 4, 5, 7, next iteration.

and

compares 3 to 6, 4, 5, 7, next iteration.

You could do this by incrementing another variable for every move operation, and decrementing this variable after the j-for loop (with a minimum of 0). Start j at i + this other variable. Like that, it would, after the 3 moves in the first iteration, start the second iteration off at index 4 (i = 2, move counter = 3 - 1 iteration passed = 2).

---

Alternatively, accept that sorting sheets is likely to be fast already, and don't spend time on this beyond adding the two simple improvements. Maybe store UCase(myBook.Sheets(j).Name) and UCase(myBook.Sheets(i).Name) in temporary variables.

Answer 2

Application.DisplayAlerts = False

Switching DisplayAlerts, ScreenUpdating, EnableEvents on and off in different subs is really a strange thing and could cause confusion when you further develop your code.

destinationWorkbook.Sheets("Sheet3").Delete

Number of Worksheets in a new workbook can be change in Excel, also with different language settings name can be different, so I'd use:

With destinationWorkbook
    Do While .WorkSheets.Count > 1
        .WorkSheets(2).Delete
    Loop
    .WorkSheets(1).Name = "Sheet1" ' just to be sure:)
End With

If Len(strFilename) = 0 Then Exit Sub

It'd be elegant to close destinationWorkbook if no copy is performed.

Private Sub AlphebetizeSheets(ByVal myBook As Workbook)

Instead of sorting at the end, you could insert the worksheets already to the right place. So intead of
sourceWorksheet.Copy After:=destinationWorkbook.Worksheets(destinationWorkbook.Worksheets.Count)
You could get something like:
sourceWorksheet.Copy After:=FindPreviousSheet(destinationWorkbook, sourceWorksheet.Name)
Where FindPreviousSheet would look for the right position, either with log search (also you can rename Sheet1 to _Sheet1 to avoid the need of inserting to the first position).

If .Show <> -1 Then GoTo FolderPicked
directoryName = .SelectedItems(1)

Why not the below way???

If .Show = -1 Then directoryName = .SelectedItems(1)

Update

Example binary search function:

Function FindPreviousSheet(WkBook as WorkBook, NewName as String) as WorkSheet
    Dim lGuess as Long, uGuess as Long
    Dim newGuess as Long

    lGuess = 1
    uGuess = WkBook.Sheets.Count
    do while uGuess - lGuess > 1
        newGuess = cInt((uGuess-lGuess)/2)
        if lCase(WkBook.Sheets(newGuess) > lCase(NewName) Then
            uGuess = newGuess
        Else
            lGuess = newGuess
        End If
    Loop
    set FindPreviousSheet = WkBook.Sheets(Iif(lCase(WkBook.Sheets(uGuess) > lCase(NewName),lGuess,uGuess))