# A practical example of evenly distributing n lists into a single list

I had previously asked about how to evenly distribute the items in n lists into a single list and was referred to this question.

I made a practical example of my solution for this in VBA for Excel, since my application for this was resorting my Spotify lists which can be easily pasted into Excel for manipulation. Assumptions are that you have a headerless worksheet (wsSource) of songs with columns A, B, C representing Artist, Song, SpotifyURI respectively, a "Totals" worksheet (wsTotals) containing the sum of songs for each Artist from wsSource sorted in descending order, and a "Destination" worksheet where the new list will be created.

Here's a link to the sample file.

Could I get some suggestions to improve this? I was going to get rid of the totals worksheet and have this portion done in code, but I have to go and I wanted to go ahead and put this out there.

Sub WeaveSort()

Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double

Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")
iLast = wsTotals.Range("A1").End(xlDown).Row - 1

For i = 2 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row

If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If

dDiff = iDest / iSource
dDiffSum = 0
iNewRow = 0

For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow

wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
NextI:
Next i

End Sub

-

One word.... VELOCIRAPTORS.

You seem like a nice guy, I don't want the raptors to get you, so let's take Heslacher's advice and move this code outside of the loop.

    If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If


Since we'll handling the special case of the first row outside the loop, we need to change which row the loop starts on. While we're at it, let's get rid of that magic number and replace it with a variable. Note that I also replaced i with the more meaningful name row.

iSource = wsTotals.Range("B2").Value
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)

Dim startRow As Long
startRow = 3
For row = startRow To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row


Now that the dreaded GoTo has been banished, let's see what else we can clean up.

• There's no sense in assigning ThisWorkbook to a variable. There's no need to keep an extra reference to it in memory. Just do this. (Note that although I hate hungarian notation, I find using wb for workbook and ws for worksheet acceptable. The intention is clear to any VBA developer.)

Set wsTotals = ThisWorkbook.Worksheets("Totals")
Set wsSource = ThisWorkbook.Worksheets("Source")
Set wsDest = ThisWorkbook.Worksheets("Dest")

• Your method of finding the last row has unpredictable results. Use this instead.

lastRow = wsTotals.Range("A" & wsTotals.Rows.Count).End(xlUp).row

• Same deal with finding the destination row.

iDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).row


Applying most of Vogel612's naming suggestions, this is the code up to this point.

Sub WeaveSort()

Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim row As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Dim sourceRow As Integer
Dim oldRow As Integer
Dim newRow As Integer
Dim difference As Double
Dim differenceSum As Double

Set wsTotals = ThisWorkbook.Worksheets("Totals")
Set wsSource = ThisWorkbook.Worksheets("Source")
Set wsDest = ThisWorkbook.Worksheets("Dest")

lastRow = wsTotals.Range("A" & wsTotals.Rows.Count).End(xlUp).row - 1

sourceRow = wsTotals.Range("B2").Value
wsDest.Range("A1:C" & sourceRow).Value2 = wsSource.Range("A1:C" & sourceRow).Value2
wsSource.Range("A1:C" & sourceRow).Delete (xlShiftUp)

Dim startRow As Long
startRow = 3
For row = startRow To lastRow
sourceRow = wsTotals.Range("B" & row).Value
destinationRow = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).row

difference = destinationRow / sourceRow
differenceSum = 0
newRow = 0

For oldRow = 1 To sourceRow
difference = destinationRow / sourceRow
differenceSum = differenceSum + difference
newRow = Round(differenceSum, 0)
wsSource.Rows(oldRow).Copy
wsDest.Rows(newRow).Insert xlShiftDown
destinationRow = destinationRow + 1
Next oldRow

wsSource.Range("A1:C" & sourceRow).Delete (xlShiftUp)
Next row

End Sub


We introduced a little duplication when we got rid of the raptors. Let's introduce a sub to delete the data from the source. To make things easy, we'll declare the different worksheets at the module level.

Option Explicit

Private wsDest As Worksheet
Private wsSource As Worksheet
Private wsTotals As Worksheet

Private Sub DeleteFromSource(ByVal row As Long)
wsSource.Range("A1:C" & row).Delete (xlShiftUp)
End Sub


Changing WeaveSort to:

Sub WeaveSort()

Dim row As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Dim sourceRow As Integer
Dim oldRow As Integer
Dim newRow As Integer
Dim difference As Double
Dim differenceSum As Double

Set wsTotals = ThisWorkbook.Worksheets("Totals")
Set wsSource = ThisWorkbook.Worksheets("Source")
Set wsDest = ThisWorkbook.Worksheets("Dest")

lastRow = wsTotals.Range("A" & wsTotals.Rows.Count).End(xlUp).row - 1
sourceRow = wsTotals.Range("B2").Value

wsDest.Range("A1:C" & row).Value2 = wsSource.Range("A1:C" & row).Value2
DeleteFromSource sourceRow

Dim startRow As Long
startRow = 3
For row = startRow To lastRow
sourceRow = wsTotals.Range("B" & row).Value
destinationRow = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).row

difference = destinationRow / sourceRow
differenceSum = 0
newRow = 0

For oldRow = 1 To sourceRow
difference = destinationRow / sourceRow
differenceSum = differenceSum + difference
newRow = Round(differenceSum, 0)
wsSource.Rows(oldRow).Copy
wsDest.Rows(newRow).Insert xlShiftDown
destinationRow = destinationRow + 1
Next oldRow

DeleteFromSource sourceRow
Next row

End Sub


Ultimately leaving this clever solution unchanged, but much more understandable.

-

Passing on the wisdom here, it's seldom that I review vba, I hope someone more competent comes along and touches on the aspects I didn't touch. (read: everything but names)

## Variables:

Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double

Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")


There's a lot to say here. First off: Constants. The workbooks' names will never change, so I'd declare them as constants:

Const totalsWSName As String = "Totals"
Const sourceWSName As String = "Source"
Const destinationWSName As String = "Dest"


And use as:

Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets(totalsWSName)
Set wsSource = wb.Worksheets(sourceWSName)
Set wsDest = wb.Worksheets(destinationWSName)


next up, names. You use some quirky naming here.

I am not fond of misusing hungarian notation, opposing to how it was originally intended. There's a nice article by Joel Spolsky on apps hungarian vs systems hungarian. I recommend you read it, because he's higlighting some very important aspects on when to use hungarian notation and when not.

In your code you use systems hungarian. This is the bad sort. I recommend you distance yourself from using hungarian notation to prefix types. Your variable names should show what exactly you mean.

wb --> workbook
wsDest --> destinationSheet
wsSource --> sourceSheet
wsTotals --> totalsSheet
i --> i
iLast --> totalsRows
iDest --> destinationRow
iSource --> sourceRow
iOldRow --> oldRow
iNewRow --> newRow
dDiff --> difference
dDiffSum --> differenceSum


The types are not exactly relevant and make understanding the variable name harder. I tried to rename the variables so they express what they are doing, without being prefixed with anything.

In general it can be said:
Avoid hungarian notation wherever possible, because you are likely to get it wrong. And if you can't help using it, using it fully through the bench usually is not the correct way.

So much from my side ;)

-
The names of the worksheets could be constants, but the workbook themselves have to be assigned to a variable at runtime. –  RubberDuck Aug 11 '14 at 10:53
@ckuhn203 dammit. Would have been so nice ;) check the edit. –  Vogel612 Aug 11 '14 at 11:01
It would be nice wouldn't it? Your edit works, but a constant for a string that appears once might be overkill. =) Regardless, you had my up vote for mentioning the Hungarian notation. –  RubberDuck Aug 11 '14 at 11:05
very informative article! most of my experience has been with vba, where programmers apparently still live in the dark ages of systems hugarian notation. thanks for showing me the light! –  ForrestA Aug 11 '14 at 18:28

To what Vogel612 already has written I would like to add that you should refactor this

If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If


to be outside of your outer loop. You can also remove iNewRow = 0 and dDiff = iDest / iSource, because you are assigning new values inside the inner loop to these variables.

Edit After reading ckuhn203 answer, I see what I have forgotten. The starting index of the outer for loop needs to be changed to 3.

iSource = wsTotals.Range("B" & 2).Value
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)

For i = 3 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row

dDiffSum = 0

For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow

wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)

Next i

-
iSource is the count of items in the current list being moved and is the limit of the inner loop, so I think it needs to be recalculated for each list if all else remains the same. –  ForrestA Aug 11 '14 at 15:07
@ForrestA, As wsTotals won't change inside the loops iSource won't change and therefor won't need to be recalculated. iSource = wsTotals.Range("B" & i).Value –  Heslacher Aug 11 '14 at 15:11
I think I may be having a brain fart, but let's say in wsTotals Range("B2") = 12 and Range("B3") = 9. If I don't redefine iSource after i gets incremented from 2 to 3, my iSource will still be 12 even though the list now being moved from wsSource to wsDest only has 9 items. I'm still a little sleepy though, so let me know if I've missed something. –  ForrestA Aug 11 '14 at 15:21
A perfect example of why I should change my variable names, as @vogel612 suggested. –  ForrestA Aug 11 '14 at 15:37

Just wanted to follow up on this. 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. Let me know if this needs to be a new thread.

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

-