# Pick a folder and consolidate workbooks

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.EnableEvents = False
Application.ScreenUpdating = False

Dim destinationWorkbook As Workbook
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.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.

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.

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.

• In this answer: getting sidetracked completely by the first utility function even although it is a utility function that will be called a very small amount of times for small N Apr 19, 2016 at 13:20
• Thanks, I hadn't seen the reference. The only other thing I could think of was putting the names in an array and sorting that? But that seemed rough as well. Dammit the VBE needs a spellchecker! Apr 19, 2016 at 13:22
• TBH I'd make an array and hand it off to a built-in sort function with a comparison function... but I don't know if such a thing exists in VBA. Something like sort(myBook.Sheets, function(a, b){ return StrComp(UCase(a.Name), UCase(b.Name), CompareMethod.Text);}) Apr 19, 2016 at 13:23
• @Pimgd There are no built-in Array-Sort functions in VBA (that you can access via the object model).
– Kaz
Apr 19, 2016 at 13:26
• Also your example of the way the sort works really exposes the absurdity of my method. Apr 19, 2016 at 13:29

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))

• Great suggestions. But, I ended up turning screenupdating etc on and off in each procedure. Maybe I need to create a main sub to call them all in order? Apr 20, 2016 at 14:41
• Yes, I agree, best practice is turn it on/off in each procedure. Which I commented that you've switched it off in one procedure, then switched on in another. You can even use a small sub for it like here in "Procedure for increasing VBA performance" Apr 20, 2016 at 14:45
• What is "Log Search"? My google fu is failing me. Apr 20, 2016 at 17:04
• Maybe correct name is binary / quick search. It needs log (n) time. Apr 20, 2016 at 19:46
• FYI - "why not collect declarations at the beginning of sub?" would have earned you my downvote if it wasn't of the rest of this beautiful answer. In every modern (even not-so-modern) language, best-practice is to declare variable as close as possible to their usage - I don't see any valid reason to treat VB code any differently. May 12, 2016 at 16:25