PDA

View Full Version : Sleeper: Unique Array Help / Code cleanup wanted



mvidas
11-19-2004, 11:26 AM
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
11-20-2004, 08:25 AM
Hi Matt,
The questioner reposted here, and I've posted a spreadsheet approach for consideration
MD
http://www.experts-exchange.com/Applications/MS_Office/Excel/Q_21213833.html

mvidas
11-22-2004, 08:57 AM
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 :)