Evenly distribute a short column of values into a longer column

[opus13]

Is there a way to even distribute the contents of one column into another?

I've got a column of 19,268 values, and need to (roughly) evenly distribute another 732 values into the column.


[TABLE="width: 600"]
<tbody>[TR]
[TD="align: center"]A[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]A[/TD]
[/TR]
[TR]
[TD="align: center"] B[/TD]
[TD="align: center"] 2[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"] B[/TD]
[/TR]
[TR]
[TD="align: center"]C[/TD]
[TD="align: center"]3[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]1[/TD]
[/TR]
[TR]
[TD="align: center"]D[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]C[/TD]
[/TR]
[TR]
[TD="align: center"]E[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]-->[/TD]
[TD="align: center"]D[/TD]
[/TR]
[TR]
[TD="align: center"]F[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]2[/TD]
[/TR]
[TR]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]E[/TD]
[/TR]
[TR]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]F[/TD]
[/TR]
[TR]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]3[/TD]
[/TR]
[TR]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD="align: center"]
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Illustrations always say it easier than words.

Thanks.

 

[Teeroy]

This might work for you. I've assumed that the first data is in A1 down, and the new data in B1 down.

Sub Insert_Other_Data()
Dim lOrigDataRows As Long, lNewData As Long, lGroupRows As Long
lOrigDataRows = Range("A" & Rows.Count).End(xlUp).Row
lNewData = Range("B" & Rows.Count).End(xlUp).Row
lGroupRows = Int(lOrigDataRows / lNewData)
Temp = Range("B1:B" & lNewData)
'insert last number
Range("A" & lOrigDataRows + 1) = Temp(UBound(Temp), 1)
For i = lNewData - 1 To 1 Step -1
    'insert blank row
    Rows(i * lGroupRows).Insert
    'insert next value
    Cells(i * lGroupRows, 1).Value = Temp(i, 1)
Next i
End Sub

 

[opus13]

This might work for you. I've assumed that the first data is in A1 down, and the new data in B1 down.

Sub Insert_Other_Data()
...
End Sub

You, dear sir, are one that I owe a beer. Thank you. Next time you happen to be Colorado, let me know and i'll make good on it .

Just for fun, this is what that string running on a column of 732 going into a column of 19,268 looks like in system usage.

 

[GTO]

Hi there,

Here is my try. A bit longer, but I tried to keep the interspersing as "even" as possible if that makes sense.

With the 19268 values in Col A and the 732 values in Col B (both starting at row 2), like (truncated of course) :

Excel Workbook
	A	B	C	D	E
1	Long Column	Short Column			Results
2	an	1			an
3	ana	2			ana
4	anabaena	3			anabaena
5	anabantidae	4			anabantidae
6	anabaptism	5			anabaptism
7	anabaptist	6			anabaptist
8	anabaptistic	7			anabaptistic
9	anabaptistical	8			anabaptistical
10	anabaptistically	9			anabaptistically
11	anabaptistry	10			anabaptistry
12	anabaptize	11			anabaptize
13	anabas	12			anabas
14	anabasine	13			anabasine
15	anabasis	14			anabasis
16	anabasse	15			anabasse
17	anabata	16			anabata
18	anabathmos	17			anabathmos
19	anabatic	18			anabatic
20	anabel	19			anabel
21	anaberoga	20			anaberoga
22	anabibazon	21			anabibazon
23	anabiosis	22			anabiosis
24	anabiotic	23			anabiotic
25	anablepidae	24			anablepidae
26	anableps	25			anableps
27	anabo	26			anabo
28	anabohitsite	27			1
29	anabolic	28			anabohitsite
Sheet1

Excel 2010

In a Standard module:

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

Hope that helps,

Mark

 

[Teeroy]

You are welcome.

And the beer is safe, I haven't been to Colorado in 7 years though at one point I was going through there every 3 months, and all I saw was the Rockies (fantastic view when landing) and Denver airport .