MOST & LEAST OCCURRING INTEGERS !

F

flex zax

I need help with the following please:

1. In sheetA Range("A2:B200") there is a price list (integers). I need
a macro that will loop through the range and list the 4 integers which
appear most in the range. The macro should list these 4 most occuring
integers in Range("C2:C4")

2. Also, I need a second macro that will list the 4 least occurring
integers in the same range("A2:B200"). This list should be placed in
Range("D2:D4)

I will greatly appreciate any assistance. Thanks.
~Flex~

*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!
 
T

Tom Ogilvy

What to do with ties,

1 occurs 10 times
2 occurs 9 times
3 occurs 8 times
4 occurs 8 times
5 occurs 8 times
6 occurs 8 times

What is the range of your integers. 0 to 100 as an example.

the list is in both column A and B?
 
F

flex zax

Hi Tom -
* If there are ties, list all of the ties as well in range("C") even
though the usual 4 (if no ties) would be in range("C2:C4).

* The range of the integers are from 0 to 100. Some integers appear
multiple times and others not at all.

*What I meant by Range("A:B") was that any cell in any of these column
can contain any value. But all integers are in columns A and B.

Thanks in advance.
~Flex~


*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!
 
T

Tom Ogilvy

This adds a "scratch" sheet and does all the work on this sheet. Then it
writes the results where you specified.

I have commented out the code to delete the added sheet. You can look at it
to make sure the macro is getting the correct values. Once you are
satisfied the macro works, you can uncomment the sh1.Delete code and the
macro will delete the scratch sheet. On the scratch sheet, the integers are
listed in column C and the frequencies in D

In C2 is the 4th highest occuring value down to the highest value
In D2 is the lowest value down to the 4th lowest.

Sub GetExtremes()
Dim sh As Worksheet, sh1 As Worksheet
Dim rng1 As Range, Large4 As Long, Small4 As Long
Dim rngSmall As Range, rngLarge As Range
Dim resSmall As Variant, resLarge As Variant
Set sh = ActiveSheet
Set sh1 = Worksheets.Add
sh1.Range("A2:A200").Value = sh.Range("A2:A200").Value
sh1.Range("A201:A399").Value = sh.Range("B2:B200").Value
sh1.Range("A2:A400").Sort Key1:=sh1.Range("A2"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
sh1.Range("A1").Value = "Header1"
sh1.Range("C1").Value = "Header1"
sh1.Range("A1:A399").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("C1"), _
Unique:=True
Set rng1 = sh1.Range(sh1.Range("C2"), _
sh1.Range("C2").End(xlDown))
rng1.Offset(0, 1).Formula = "=Countif(A:A,C2)"
rng1.Offset(0, 1).Formula = rng1.Offset(0, 1).Value
rng1.Resize(, 2).Sort Key1:=rng1.Offset(0, 1), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Large4 = Application.Large(rng1.Offset(0, 1), 4)
Small4 = Application.Small(rng1.Offset(0, 1), 4)
resLarge = Application.Match(Large4, rng1.Offset(0, 1), 0)
Set rngLarge = sh1.Range(rng1(resLarge), rng1(rng1.Count))
sh.Range("C2").Resize(rngLarge.Count, 1).Value = _
rngLarge.Value
resSmall = Application.Match(Small4, rng1.Offset(0, 1), 1)
Set rngSmall = sh1.Range(rng1(1), rng1(resSmall))
sh.Range("D2").Resize(rngSmall.Count, 1).Value = _
rngSmall.Value
sh.Activate
Application.DisplayAlerts = False
'sh1.Delete
Application.DisplayAlerts = True
End Sub
 
R

Rob van Gelder

Flex,

WorksheetFunction.Large and WorksheetFunction.Small are your keywords here.

Sub test()
Const cCount = 4
Dim rng As Range, i As Long, j As Long, lngTemp As Long, lngLast As Long

With Sheet1
Set rng = .Range("A:B")

'Largest
i = 1: j = 0
Do Until j = cCount
lngTemp = WorksheetFunction.Large(rng, i)
.Cells(i + 1, 3).Value = lngTemp
i = i + 1
If j = 0 Or lngLast <> lngTemp Then
lngLast = lngTemp
j = j + 1
End If
Loop

'Smallest
i = 1: j = 0
Do Until j = cCount
lngTemp = WorksheetFunction.Small(rng, i)
.Cells(i + 1, 4).Value = lngTemp
i = i + 1
If j = 0 Or lngLast <> lngTemp Then
lngLast = lngTemp
j = j + 1
End If
Loop
End With
End Sub
 
Top