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" &amp; i).Value
        iDest = wsDest.Range("A99999").End(xlUp).Row

        If i = 2 Then
            wsDest.Range("A1:C" &amp; iSource).Value2 = wsSource.Range("A1:C" &amp; iSource).Value2
            wsSource.Range("A1:C" &amp; 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" &amp; 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" &amp; iSource).Value2 = wsSource.Range("A1:C" &amp; iSource).Value2
        wsSource.Range("A1:C" &amp; 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" &amp; iSource).Value2 = wsSource.Range("A1:C" &amp; iSource).Value2
wsSource.Range("A1:C" &amp; iSource).Delete (xlShiftUp)

Dim startRow As Long
startRow = 3
For row = startRow To iLast
    iSource = wsTotals.Range("B" &amp; 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" &amp; wsTotals.Rows.Count).End(xlUp).row

Same deal with finding the destination row.

iDest = wsDest.Range("A" &amp; 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" &amp; wsTotals.Rows.Count).End(xlUp).row - 1

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

    Dim startRow As Long
    startRow = 3
    For row = startRow To lastRow
        sourceRow = wsTotals.Range("B" &amp; row).Value
        destinationRow = wsDest.Range("A" &amp; 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" &amp; 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" &amp; 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" &amp; wsTotals.Rows.Count).End(xlUp).row - 1
    sourceRow = wsTotals.Range("B2").Value

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

    Dim startRow As Long
    startRow = 3
    For row = startRow To lastRow
        sourceRow = wsTotals.Range("B" &amp; row).Value
        destinationRow = wsDest.Range("A" &amp; 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.