# Update on Weave Merging n lists into single list

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 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
sign = 1

Do While destinationWs.Range("A" & newRow).Value2 <> 0
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


# 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
sign = 1

Do While destinationWs.Range("A" & newRow).Value2 <> 0
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
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.

• I took your advice on switching up my implementation and it went from taking 30 seconds to .05 seconds. I didn't do it quite how you did though. Instead of reading and writing all of my operations to and from the sheet like I was, I read my original list of songs into an array, created a sorted list in a new array, then wrote the sorted list to the worksheet. Thanks for the tips! – ForrestA Jun 5 '15 at 21:24