Update on Weave Merging n lists into single list

Question

This is a follow up to my previous post from 7 months ago. I changed up the algorithm a little. Instead of inserting items into a new list, each item's final place is calculated up front. Sort of like if instead of resizing an array each time I add a new item, I'm sizing it up front and just setting the value of each element. If the place is already occupied, the closest open place is found. This avoids everything getting shifted around as new items are inserted into the list, so every item is as close as possible to it's ideal place in the new list.

Sub TrueShuffle()

    ' object declarations
    Dim xl As Object ' Excel.Application
    Dim wb As Object ' Excel.Workbook
    Dim destinationWs As Object ' Excel.Worksheet
    Dim sourceWs As Object ' Excel.Worksheet
    Dim totalsWs As Object ' Excel.Worksheet

    ' variable declarations
    Dim artistName As String
    Dim quotient As Double
    Dim quotientSum As Double
    Dim timeElapsed As Double
    Dim pivotRows As Integer
    Dim songCount As Integer
    Dim artist As Integer
    Dim song As Integer
    Dim artistSongs As Integer
    Dim oldRow As Integer
    Dim newRow As Integer
    Dim adjustment As Integer
    Dim first As Integer
    Dim sign As Integer

    ' start timer and turn off screen updating
    timeElapsed = Timer
    Application.ScreenUpdating = False

    ' set xl objects
    Set wb = ThisWorkbook
    Set totalsWs = wb.Worksheets("Totals")
    Set sourceWs = wb.Worksheets("Source")
    Set destinationWs = wb.Worksheets("Dest")

    ' opening operations
    songCount = sourceWs.Range("A1").End(xlDown).row - 1    ' total songs in destination sheet
    totalsWs.PivotTables("SongCount").ChangePivotCache _
        wb.PivotCaches.Create(SourceType:=xlDatabase _
                            , SourceData:="Source!A1:C" & songCount + 1)   ' set pivot data source range
    totalsWs.PivotTables("SongCount").RefreshTable    ' refresh pivot table
    pivotRows = totalsWs.Range("B1").End(xlDown).row    ' total rows in pivot table
    destinationWs.Cells.Delete    ' clear destination sheet

    ' iterate through each artist in pivot table
    For artist = 2 To pivotRows - 1
        artistName = totalsWs.Range("A" & artist).Value2
        artistSongs = totalsWs.Range("B" & artist).Value2    ' song count for current artist

        Select Case artist
        Case 2    ' first artist takes first place in destination list
            oldRow = sourceWs.Range("A2:A" & songCount + 1).Find(artistName, sourceWs.Range("A" & songCount + 1)).row
            sourceWs.Range("A" & oldRow & ":C" & oldRow).Copy destinationWs.Range("A1:C1")
            quotient = (songCount - 1) / (artistSongs - 1)
            quotientSum = 1
            first = 2    ' first song is placed before loop, so start from second song
        Case Else
            oldRow = songCount + 1    ' set to ensure the search for an artists songs starts from the beginning of the source list
            quotient = songCount / artistSongs
            quotientSum = (-quotient) / 2    ' offset placement within the list by half the quotient
            first = 1
        End Select

        For song = first To artistSongs
            ' insert each song into destination sheet by incrementing by the
            ' artistSongs:songCount quotient and rounding to the nearest integer
            quotientSum = quotientSum + quotient
            oldRow = sourceWs.Range("A2:A" & songCount + 1).Find(artistName, sourceWs.Range("A" & oldRow)).row
            newRow = Round(quotientSum, 0)

            On Error Resume Next

            ' find the closest empty space
            adjustment = 1
            sign = 1

            Do While destinationWs.Range("A" & newRow).Value2 <> 0
                newRow = newRow + adjustment
                adjustment = (adjustment + sign) * (-1)
                sign = sign * (-1)
            Loop

            On Error GoTo 0

            sourceWs.Range("A" & oldRow & ":C" & oldRow).Copy destinationWs.Range("A" & newRow & ":C" & newRow)
        Next song
    Next artist

    ' clear objects from memory
    Set totalsWs = Nothing
    Set sourceWs = Nothing
    Set destinationWs = Nothing
    Set wb = Nothing

    ' turn on screen updating and calculate time elapsed
    Application.ScreenUpdating = True
    timeElapsed = Timer - timeElapsed

    MsgBox "TrueShuffled " & songCount & " songs in " & Round(timeElapsed, 2) & " seconds!", , "You Just Got TrueShuffled!"

End Sub

Answer 1

Error Handling (and avoidance)

First, I would either add error handling or replace code that can throw errors with code that can't. For example, on an empty Worksheet this line will throw an overflow error:

songCount = sourceWs.Range("A1").End(xlDown).row - 1    ' total songs in destination sheet

I would personally replace this with a call to .UsedRange:

songCount = sourceWs.UsedRange.Rows.Count

What an error handler will do is let you clean up anything in the environment that had already been changed back to a safe setting. I.e.

Application.ScreenUpdating = False

I generally use a template something like the following:

Option Explicit

Public Sub TrueShuffle()

    On Error GoTo ErrorHandler

    '... Code here ...

ErrorHandler:
    If Err.Number <> 0 Then
        MsgBox "Error " & Err.Number & vbCrLf & Err.Description
    End If

    'Turn screen updating back on.
    Application.ScreenUpdating = True

End Sub

Note that I also explicitly declared the scope of the Sub as Public and set Option Explicit, both of which you should be in the habit of doing.

Needless to say, turning error handling off instead of avoiding errors is generally not the best strategy, especially with a while loop between turning it off and turning it back on:

On Error Resume Next

' find the closest empty space
adjustment = 1
sign = 1

Do While destinationWs.Range("A" & newRow).Value2 <> 0
    newRow = newRow + adjustment
    adjustment = (adjustment + sign) * (-1)
    sign = sign * (-1)
Loop

On Error GoTo 0

Let's assume for the sake of argument that the expression that throws the error is this (which is the most likely place you'll get a throw):

destinationWs.Range("A" & newRow).Value2

If the error is caused by newRow being out of bounds (for example 0 or negative), it's possible if not likely that you'll "Resume Next" in an infinite loop.

Other Notes

Remove unused variables:

Dim xl As Object ' Excel.Application is never even set.

Try to avoid declaring variables as "Object" unless you are using late binding or a COM object that doesn't have clean marshalling behavior - use the explicit type declarations:

Dim wb As Workbook, destinationWs As Worksheet, sourceWs As Worksheet
Dim totalsWs As Worksheet

When you declare them as "Object", you are using the IDispatch interface of the object instead of the IUnknown interface, and that carries a ton of overhead as compared to using the registered type definition. There's a really good explanation of the difference here.

Addressing cells with the alphanumeric addresses is really slow - column and row indexes are usually about twice as fast. Interestingly, the string concatenation isn't what slows it down (although it certainly doesn't help) - it's whatever Excel is doing to resolve the address:

Dim cell As Range
Set cell = ActiveSheet.Range("A" & 1)     '375 ms over 200000 calls.
Set cell = ActiveSheet.Range("A1")        '343 ms over 200000 calls.
Set cell = ActiveSheet.Cells(1, 1)        '156 ms over 200000 calls.

Using the Excel .Copy() function will destroy whatever the user has on the clipboard (rather poor form), and can also fail with a runtime error 1004 if another application happens to be reading or writing to it. Since the Ranges are the same size, you can simply assign the values from one to the other. If they aren't the same size, just resize the destination Range and do the same thing:

sourceWs.Range("A" & oldRow & ":C" & oldRow).Copy destinationWs.Range("A" & newRow & ":C" & newRow)
'...becomes...
destinationWs.Range("A" & newRow & ":C" & newRow).Value2 = sourceWs.Range("A" & oldRow & ":C" & oldRow).Value2 

Select or switch structures traditionally have another level of indentation for the cases to make them easier to read...

Select Case artist
    Case 2
        '...
    Case Else
        '...
End Select 

...although in this case, there is no reason to use a select with only 2 cases - If ... Else is much clearer:

If artist = 2 Then
    '...
Else
    '...
End If

Finally, you shouldn't keep row counters in Integer types. They are only 16 bit and an Excel sheet can have enough rows to overflow them.

Dim newRow As Integer    'Runtime error 6 waiting to happen.
Dim newRow As Long       'Much better.

Sorting Method

While the algorithm that you use looks solid, using it the way you are in Excel VBA completely disregards what Excel is good at - which is handling large amounts of data in tables. You are going to have a hard time finding a VBA routine that performs a sorting function better than the built-in sorts. What you are really after here is a way to provide your own sort criteria, so your focus should be solely on doing that. Pick an unused column, write sort criteria to it, and use it to sort the sheet - it's as simple as that. This is a quick sample as to how I would go about this (error handler omitted because this is already a much longer post than intended). Assumes that the artist is in column A, no headers, and that column E is unused:

'Requires a reference to Microsoft Scripting Runtime
Private Sub FastShuffle()

    Dim sheet As Worksheet, length As Long, artistCounts As Dictionary
    Dim startTime As Double

    startTime = Timer
    Set sheet = ActiveSheet
    length = sheet.UsedRange.Rows.count
    Set artistCounts = New Dictionary

    'Pass 1 - get song and artist counts.
    Dim artist As String, row As Long
    For row = 1 To length
        artist = sheet.Cells(row, 1).Value2
        If Not artistCounts.Exists(artist) Then
            Call artistCounts.Add(artist, 1)
        Else
            artistCounts(artist) = artistCounts(artist) + 1
        End If
    Next row

    'Pass 2 - write sort criteria to an empty row.
    Dim numArtists As Long, last As String, counter As Long
    'Need to be sorted for this pass.
    Call sheet.UsedRange.Sort(sheet.Columns(1))

    For row = 1 To length
        'Get the artist to use as the key.
        artist = sheet.Cells(row, 1).Value2
        'Reset the counter if the artist changed.
        If artist <> last Then
            counter = 0
            last = artist
        End If
        counter = counter + 1
        'Calculate where it falls in the sort.
        sheet.Cells(row, 5).Value2 = counter / artistCounts(artist)
    Next row

    'Now just sort on the criteria column and delete it.
    Call sheet.UsedRange.Sort(sheet.Columns(5))
    sheet.Columns(5).Delete

    Debug.Print "FastShuffled " & length & " songs from " & (UBound(artistCounts.Keys) + 1) _
                & " artists in " & Timer - startTime & " seconds."

End Sub

Sample output:

FastShuffled 30000 songs from 190 artists in 1.359375 seconds.

When you approach an Excel VBA problem from within the context of Excel's (and VBA's) strengths and weaknesses, you end up with much more readable and less fragile code. It works with one Worksheet, sorts it in place, doesn't require a pivot table, and doesn't nuke the clipboard. It's also clear what it is doing, concise, and efficient.