Sleeper: Unique Array Help / Code cleanup wanted

[mvidas]

Hi everyone,

I just spent the better part of a couple hours working on a macro to try and help a user on EE. I definately taught myself a lot about working with arrays and what not, as I couldnt find anything like this anywhere.
But, since most of this was uncharted waters for me, I'm sure the methods I used could be improved. Anyone care to show me how? I'd love to learn

The user there had a huge spreadsheet of data that he wanted to analyze. One of the columns was age, and he wanted to group the data by age ranges (15-21, 22-29, etc). I'm going to post both the macro I made to create the data (random numbers between 15 and 87) as well as my actual macro, just to save anyone helping me a minute to write the random age code.

Here is the code:

Sub createdata()
 Randomize
 Dim i As Integer
 For i = 1 To 1000
  Cells(i, 1) = Int(Rnd() * 73) + 15
 Next i
End Sub

Sub UniqueValueRanges()
 Dim ctr As Long, col As Range, CLL As Range, arr() As Variant
 Dim ITM As String, IDX As Integer, i As Integer, NumRngs As Integer
 Dim rngs() As Variant, num As Integer, rgArr() As Variant, arrg() As Variant
Set col = Columns("A") 'data column
 ctr = 1                'first row of data in data column
 NumRngs = 10           'number of different spans of data
ReDim rngs(NumRngs + 1)
 ReDim rgArr(NumRngs)
 ReDim arr(1)
 Application.ScreenUpdating = False
 col.Insert
 Set col = Intersect(col, Rows(ctr + 1 & ":" & col.Cells(65536).End(xlUp).Row))
 col.NumberFormat = "#"
 col = col.Value
 arr(0) = col.Cells(1).Offset(-1, 0).Text
 arr(1) = col.Cells(1).Offset(-1, 0).Text
 ctr = 1
 For Each CLL In col.Cells
  If IsError(Application.Match(CLL, arr, 0)) Then
   ReDim Preserve arr(ctr)
   arr(ctr) = CLL
   ctr = ctr + 1
  End If
 Next CLL
 Do
  SortArray = False
  For IDX = 0 To UBound(arr) - 1
   If arr(IDX) > arr(IDX + 1) Then
    ITM = arr(IDX + 1)
    arr(IDX + 1) = arr(IDX)
    arr(IDX) = ITM
    SortArray = True
   End If
  Next IDX
 Loop Until Not SortArray
 num = UBound(arr)
 ReDim arrg(num)
 rngs(0) = 0
 For IDX = 1 To NumRngs
  rngs(IDX) = Int((num) / NumRngs * (IDX))
 Next IDX
 For IDX = 0 To NumRngs - 2
  rgArr(IDX) = arr(rngs(IDX)) & " - " & arr(rngs(IDX + 1) - 1)
  For i = rngs(IDX) To rngs(IDX + 1) - 1
   arrg(i) = rgArr(IDX)
  Next i
 Next IDX
 rgArr(NumRngs - 1) = arr(rngs(NumRngs - 1)) & " - " & arr(rngs(NumRngs))
 For i = rngs(NumRngs - 1) To rngs(NumRngs)
  arrg(i) = rgArr(NumRngs - 1)
 Next i
 Set col = Union(col, col.Cells(1).Offset(-1, 0))
 col.Offset(0, -1).NumberFormat = "@"
 For Each CLL In col.Cells
  CLL.Offset(0, -1) = arrg(Application.Match(CLL.Text, arr, 1) - 1)
 Next CLL
 Application.ScreenUpdating = True
End Sub

I tried playing with multiple dimensional arrays for this, but couldn't get it to work good. I'm sure that's gonna be one thing that can be improved (as I don't think 4 arrays are really necessary). Also, I made up a bad sort method, so I'm sure that can be improved as well.
Thanks to anyone who can help!

Matt

[mdmackillop]

Hi Matt,
The questioner reposted here, and I've posted a spreadsheet approach for consideration
MD
http://www.experts-exchange.com/Appl..._21213833.html

[mvidas]

Thanks MD,

I understand that (and good job with the answer, i pretty much walked away from all this for the past few days). I was just hoping someone could have helped me with this code, not for the sake of the Q but just for me. Perhaps putting them into multi-dimensional arrays or something, as I couldn't do it. I just posted this as an example of multiple single-dimensional arrays, so I could see how the same things are done using the multi arrays if possible