4
\$\begingroup\$

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 -

enter image description here

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.

\$\endgroup\$
5
\$\begingroup\$

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.

\$\endgroup\$
  • \$\begingroup\$ 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 \$\endgroup\$ – Pimgd Apr 19 '16 at 13:20
  • \$\begingroup\$ 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! \$\endgroup\$ – Raystafarian Apr 19 '16 at 13:22
  • \$\begingroup\$ 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);}) \$\endgroup\$ – Pimgd Apr 19 '16 at 13:23
  • \$\begingroup\$ @Pimgd There are no built-in Array-Sort functions in VBA (that you can access via the object model). \$\endgroup\$ – Kaz Apr 19 '16 at 13:26
  • \$\begingroup\$ Also your example of the way the sort works really exposes the absurdity of my method. \$\endgroup\$ – Raystafarian Apr 19 '16 at 13:29
3
\$\begingroup\$

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))
\$\endgroup\$
  • \$\begingroup\$ 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? \$\endgroup\$ – Raystafarian Apr 20 '16 at 14:41
  • \$\begingroup\$ 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" \$\endgroup\$ – Máté Juhász Apr 20 '16 at 14:45
  • \$\begingroup\$ What is "Log Search"? My google fu is failing me. \$\endgroup\$ – Raystafarian Apr 20 '16 at 17:04
  • \$\begingroup\$ Maybe correct name is binary / quick search. It needs log (n) time. \$\endgroup\$ – Máté Juhász Apr 20 '16 at 19:46
  • 2
    \$\begingroup\$ 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. \$\endgroup\$ – Mathieu Guindon May 12 '16 at 16:25

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.