'Add a command button (command1) to the sheet where your
'data is located and copy all of this code into the sheets'
'general delcarations area... Now, press the command button
'and answer the questions: this will ask for the row start,
'number of rows, and column start positions & will take the data
'from that range.
'Note: Only accepts starting column positions of A-V
' and will only get 9,999,999 entries before exploding!
Option Explicit
Private Sub CommandButton1_Click()
Dim MY_ARRAY1(1 To 9999999) As String
Dim MY_ARRAY2(1 To 9999999, 2) As String
Dim STEP_ARRAY1 As Double
Dim STEP_ARRAY2 As Double
Dim STEP_ARRAY3 As Double
Dim TMPCOL$
Dim TMPCOL_FIX1 As Double
Dim CURR_VAL$
Dim DOES_EXIST As Boolean
Dim MY_ARRAY2_END As Double
Dim NumRows
NumRows = InputBox("Enter the number of rows of data:", "", 600)
If Not IsNumeric(NumRows) Then MsgBox "Invalid Entry!", vbInformation +
vbOKOnly, "": Exit Sub
Dim RowStart
RowStart = InputBox("Enter the starting row number:", "", 1)
If Not IsNumeric(RowStart) Then MsgBox "Invalid Entry!", vbInformation
+ vbOKOnly, "": Exit Sub
Dim ColStart
ColStart = InputBox("Enter the starting Column letter:", "", "A")
Select Case UCase(ColStart)
Case "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L",
"M", "N", "O", "P", "Q", "R", "S", "T", "U", "V"
TMPCOL = UCase(ColStart)
Case Else
MsgBox "Invalid Entry! Please enter a valid column (A - V)",
vbInformation + vbOKOnly, "": Exit Sub
End Select
For STEP_ARRAY1 = 1 To NumRows * 5
If STEP_ARRAY1 = NumRows Then MsgBox Now
If STEP_ARRAY1 < NumRows + 1 Then
TMPCOL_FIX1 = -(RowStart - 1)
ElseIf STEP_ARRAY1 < NumRows * 2 + 1 Then
If STEP_ARRAY1 = NumRows + 1 Then TMPCOL =
Set_New_Column(TMPCOL)
TMPCOL_FIX1 = NumRows - (RowStart - 1)
ElseIf STEP_ARRAY1 < NumRows * 3 + 1 Then
If STEP_ARRAY1 = NumRows * 2 + 1 Then TMPCOL =
Set_New_Column(TMPCOL)
TMPCOL_FIX1 = NumRows * 2 - (RowStart - 1)
ElseIf STEP_ARRAY1 < NumRows * 4 + 1 Then
If STEP_ARRAY1 = NumRows * 3 + 1 Then TMPCOL =
Set_New_Column(TMPCOL)
TMPCOL_FIX1 = NumRows * 3 - (RowStart - 1)
ElseIf STEP_ARRAY1 < NumRows * 5 + 1 Then
If STEP_ARRAY1 = NumRows * 4 + 1 Then TMPCOL =
Set_New_Column(TMPCOL)
TMPCOL_FIX1 = NumRows * 4 - (RowStart - 1)
End If
MY_ARRAY1(STEP_ARRAY1) = Range(TMPCOL & (STEP_ARRAY1 -
TMPCOL_FIX1)).Value
Next
MY_ARRAY2_END = 0
For STEP_ARRAY1 = 1 To NumRows * 5
DOES_EXIST = False
CURR_VAL = MY_ARRAY1(STEP_ARRAY1)
For STEP_ARRAY2 = 1 To NumRows * 5
If MY_ARRAY2(STEP_ARRAY2, 0) = CURR_VAL Then DOES_EXIST = True:
Exit For
Next
If DOES_EXIST = False Then
MY_ARRAY2_END = MY_ARRAY2_END + 1
MY_ARRAY2(MY_ARRAY2_END, 0) = CURR_VAL
End If
Next
For STEP_ARRAY2 = 1 To MY_ARRAY2_END
For STEP_ARRAY1 = 1 To NumRows * 5
If MY_ARRAY1(STEP_ARRAY1) = MY_ARRAY2(STEP_ARRAY2, 0) Then _
MY_ARRAY2(STEP_ARRAY2, 1) = Val(MY_ARRAY2(STEP_ARRAY2, 1)) + 1
Next
Next
Dim GreatestValue(1 To 5) As Integer
Dim GreatestString(1 To 5) As String
GreatestValue(1) = 0
For STEP_ARRAY2 = 1 To 5
GreatestValue(STEP_ARRAY2) = 0
GreatestString(STEP_ARRAY2) = ""
For STEP_ARRAY3 = 1 To MY_ARRAY2_END
If Val(MY_ARRAY2(STEP_ARRAY3, 1)) > GreatestValue(STEP_ARRAY2)
Then
If STEP_ARRAY2 = 1 Then
GreatestValue(STEP_ARRAY2) = Val(MY_ARRAY2(STEP_ARRAY3,
1))
GreatestString(STEP_ARRAY2) = MY_ARRAY2(STEP_ARRAY3,
0)
ElseIf STEP_ARRAY2 = 2 Then
If MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(1) Then
GreatestValue(STEP_ARRAY2) =
Val(MY_ARRAY2(STEP_ARRAY3, 1))
GreatestString(STEP_ARRAY2) =
MY_ARRAY2(STEP_ARRAY3, 0)
End If
ElseIf STEP_ARRAY2 = 3 Then
If MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(1) And
MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(2) Then
GreatestValue(STEP_ARRAY2) =
Val(MY_ARRAY2(STEP_ARRAY3, 1))
GreatestString(STEP_ARRAY2) =
MY_ARRAY2(STEP_ARRAY3, 0)
End If
ElseIf STEP_ARRAY2 = 4 Then
If MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(1) And
MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(2) And
MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(3) Then
GreatestValue(STEP_ARRAY2) =
Val(MY_ARRAY2(STEP_ARRAY3, 1))
GreatestString(STEP_ARRAY2) =
MY_ARRAY2(STEP_ARRAY3, 0)
End If
ElseIf STEP_ARRAY2 = 5 Then
If MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(1) And
MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(2) And
MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(3) And
MY_ARRAY2(STEP_ARRAY3, 0) <> GreatestString(4) Then
GreatestValue(STEP_ARRAY2) =
Val(MY_ARRAY2(STEP_ARRAY3, 1))
GreatestString(STEP_ARRAY2) =
MY_ARRAY2(STEP_ARRAY3, 0)
End If
End If
End If
Next
Next
Dim TmpMsg$
TmpMsg = "Top 5 Greatest Values:" & vbCrLf
For STEP_ARRAY1 = 1 To 5
TmpMsg = TmpMsg & vbCrLf & "#" & STEP_ARRAY1 & " " &
GreatestString(STEP_ARRAY1) & " = " & GreatestValue(STEP_ARRAY1)
Next
MsgBox TmpMsg
End Sub
'Helper funtion to determine new column...
Private Function Set_New_Column(ByVal Starting_Column As String) As
String
Select Case Starting_Column
Case "A"
Set_New_Column = "B"
Case "B"
Set_New_Column = "C"
Case "C"
Set_New_Column = "D"
Case "D"
Set_New_Column = "E"
Case "E"
Set_New_Column = "F"
Case "F"
Set_New_Column = "G"
Case "G"
Set_New_Column = "H"
Case "H"
Set_New_Column = "I"
Case "I"
Set_New_Column = "J"
Case "J"
Set_New_Column = "K"
Case "K"
Set_New_Column = "L"
Case "L"
Set_New_Column = "M"
Case "M"
Set_New_Column = "N"
Case "N"
Set_New_Column = "O"
Case "O"
Set_New_Column = "P"
Case "P"
Set_New_Column = "Q"
Case "Q"
Set_New_Column = "R"
Case "R"
Set_New_Column = "S"
Case "S"
Set_New_Column = "T"
Case "T"
Set_New_Column = "U"
Case "U"
Set_New_Column = "V"
Case "V"
Set_New_Column = "W"
Case "W"
Set_New_Column = "X"
Case "X"
Set_New_Column = "Y"
Case "Y"
Set_New_Column = "Z"
End Select
End Function
