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