Option Explicit
Public Sub IntersperseValues()
Dim rngLong As Range
Dim rngShort As Range
Dim arrMoreVals As Variant
Dim arrLessVals As Variant
Dim dblRemainder As Double
Dim dblLeftOver As Double
Dim dblAccurateRatio As Double
Dim lngRatio As Long
Dim Extra As Long
Dim n As Long, i As Long, j As Long, k As Long
With Sheet1
Set rngLong = .Range(.Range("A2"), RangeFound(.Range(.Cells(2, 1), .Cells(.Rows.Count, 1))))
Set rngShort = .Range(.Range("B2"), RangeFound(.Range(.Cells(2, 2), .Cells(.Rows.Count, 2))))
End With
arrMoreVals = rngLong.Value
arrLessVals = rngShort.Value
ReDim arrAllVals(1 To (UBound(arrMoreVals, 1) + UBound(arrLessVals, 1)), 1 To 1)
dblAccurateRatio = UBound(arrMoreVals, 1) / UBound(arrLessVals, 1)
lngRatio = Int(dblAccurateRatio)
dblRemainder = dblAccurateRatio - lngRatio
Do While j< UBound(arrAllVals, 1)
dblLeftOver = dblLeftOver + dblRemainder
If dblLeftOver >= 1 Then
dblLeftOver = dblLeftOver - Int(dblLeftOver)
Extra = 1
Else
Extra = 0
End If
For i = 1 To (lngRatio + Extra)
n = n + 1
If n<= UBound(arrMoreVals, 1) Then
j = j + 1
arrAllVals(j, 1) = arrMoreVals(n, 1)
Else
Exit For
End If
Next
k = k + 1
If k<= UBound(arrLessVals, 1) Then
j = j + 1
arrAllVals(j, 1) = arrLessVals(k, 1)
End If
Loop
Sheet1.Range("E2").Resize(UBound(arrAllVals, 1)).Value = arrAllVals
End Sub
Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range
If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function