How to find the most common pair and triplet numbers?

Discussion in 'Microsoft Excel Programming' started by alessio971@gmail.com, Aug 11, 2007.

  1. Guest

    Hi

    I have been looking into this for few weeks now but I can't find a
    solution ...

    I have 200 rows of data composed of numbers from 1 to 10 on column A
    to F.

    I need to find out the most pair / triplet for the all table. Perhaps
    the following example will explain better


    1_2_3_4_5_6
    1_2_5_6_7_9
    2_3_5_6_7_8
    3_4_6_7_8_9
    1_3_5_6_7_8

    Most common pair = 6_7
    Most common triplet = 5_6_7

    Hope this is clear ... thank you in advance

    A
     
    , Aug 11, 2007
    #1
    1. Advertisements

  2. Guest Guest

    maybe something like this:

    Sub MostCommonPair()
    Dim rng As Range
    Dim c As Range
    Dim strPair As String
    Dim ws As Worksheet
    Dim lRow As Long
    Dim lRow2 As Long
    Dim lCount As Long

    Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    If Not rng Is Nothing Then
    Set ws = ActiveWorkbook.Worksheets.Add
    lRow = 1
    For Each c In rng
    If c.Column <= 5 Then
    strPair = c.Value & "_" & c.Offset(0, 1).Value

    On Error Resume Next
    lRow2 = Application.WorksheetFunction.Match(strPair,
    ws.Range("A:A"), False)
    If Err.Number > 0 Then
    ws.Range("A" & lRow).Value = strPair
    ws.Range("B" & lRow).Value = 1
    lRow = lRow + 1
    Else
    ws.Range("B" & lRow2).Value = ws.Range("B" &
    lRow2).Value + 1
    End If
    On Error GoTo 0
    End If
    Next c
    End If

    'get the one with largest count
    With Application.WorksheetFunction
    lCount = .Large(ws.Range("B:B"), 1)
    lRow = .Match(lCount, ws.Range("B:B"), False)
    End With
    MsgBox "Most Common Pair is " & ws.Range("A" & lRow) & " (" & lCount & "
    occurrences)"

    ws.Delete

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    End Sub


    Sub MostCommonTriplet()
    Dim rng As Range
    Dim c As Range
    Dim strTriplet As String
    Dim ws As Worksheet
    Dim lRow As Long
    Dim lRow2 As Long
    Dim lCount As Long

    Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    If Not rng Is Nothing Then
    Set ws = ActiveWorkbook.Worksheets.Add
    lRow = 1
    For Each c In rng
    If c.Column <= 4 Then
    strTriplet = c.Value & "_" & c.Offset(0, 1).Value & "_" &
    c.Offset(0, 2).Value

    On Error Resume Next
    lRow2 = Application.WorksheetFunction.Match(strTriplet,
    ws.Range("A:A"), False)
    If Err.Number > 0 Then
    ws.Range("A" & lRow).Value = strTriplet
    ws.Range("B" & lRow).Value = 1
    lRow = lRow + 1
    Else
    ws.Range("B" & lRow2).Value = ws.Range("B" &
    lRow2).Value + 1
    End If
    On Error GoTo 0
    End If
    Next c
    End If

    'get the one with largest count
    With Application.WorksheetFunction
    lCount = .Large(ws.Range("B:B"), 1)
    lRow = .Match(lCount, ws.Range("B:B"), False)
    End With
    MsgBox "Most Common Triplet is " & ws.Range("A" & lRow) & " (" & lCount
    & " occurrences)"

    ws.Delete

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    End Sub
     
    Guest, Aug 12, 2007
    #2
    1. Advertisements

  3. Guest

    THANK YOU Adriano

    works perfectly ... I want to spend some time reviewing the code to
    understand the all process.

    Thanks again
    A
     
    , Aug 12, 2007
    #3
  4. Paul Black Guest

    Hi Vergel Adriano,

    Sorry to jump in here A.
    Would it be possible to adapt the codes so it outputs ALL the
    combinations of Pairs & Triplets with the total amount of times they
    have appeared please.
    Maybe the results could go in a sheet named "Results" and :-
    (1) The Pairs go in Cells "A1" & "B1" going down and the total times
    appeared in Cell "C1" going down.
    (2) The Triples go in Cells "E1", "F1" & "G1" going down and the total
    times appeared in Cell "H1" going down.

    Thanks in Advance.
    All the Best.
    Paul
     
    Paul Black, Aug 12, 2007
    #4
  5. Guest Guest

    Hi Paul,

    Give this a try.

    Sub MostCommonPairAndTriplet()
    Dim rng As Range
    Dim c As Range
    Dim strPair As String
    Dim strTriplet As String
    Dim wsResult As Worksheet
    Dim lRow As Long
    Dim lRow2 As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

    If Not rng Is Nothing Then

    'Get the result worksheet
    On Error Resume Next
    Set wsResult = ActiveWorkbook.Worksheets("Results")
    If wsResult Is Nothing Then
    Set wsResult = ActiveWorkbook.Worksheets.Add
    wsResult.Name = "Results"
    Else
    wsResult.UsedRange.Delete
    End If
    'column labels
    With wsResult
    .Range("B1").Value = "Value1"
    .Range("C1").Value = "Value2"
    .Range("D1").Value = "Count"
    .Range("F1").Value = "Value1"
    .Range("G1").Value = "Value2"
    .Range("H1").Value = "Value3"
    .Range("I1").Value = "Count"
    End With
    On Error GoTo 0

    'Find Pairs
    lRow = 2
    For Each c In rng
    If c.Column <= 5 Then
    strPair = c.Value & "_" & c.Offset(0, 1).Value

    On Error Resume Next
    lRow2 = Application.WorksheetFunction.Match(strPair,
    wsResult.Range("A:A"), False)
    If Err.Number > 0 Then
    wsResult.Range("A" & lRow).Value = strPair
    wsResult.Range("B" & lRow).Value = c.Value
    wsResult.Range("C" & lRow).Value = c.Offset(0, 1).Value
    wsResult.Range("D" & lRow).Value = 1
    lRow = lRow + 1
    Else
    wsResult.Range("D" & lRow2).Value = wsResult.Range("D" &
    lRow2).Value + 1
    End If
    On Error GoTo 0
    End If
    Next c

    'Find Triplets
    lRow = 2
    For Each c In rng
    If c.Column <= 4 Then
    strTriplet = c.Value & "_" & c.Offset(0, 1).Value & "_" &
    c.Offset(0, 2).Value

    On Error Resume Next
    lRow2 = Application.WorksheetFunction.Match(strTriplet,
    wsResult.Range("E:E"), False)
    If Err.Number > 0 Then
    wsResult.Range("E" & lRow).Value = strTriplet
    wsResult.Range("F" & lRow).Value = c.Value
    wsResult.Range("G" & lRow).Value = c.Offset(0, 1).Value
    wsResult.Range("H" & lRow).Value = c.Offset(0, 2).Value
    wsResult.Range("I" & lRow).Value = 1
    lRow = lRow + 1
    Else
    wsResult.Range("I" & lRow2).Value = wsResult.Range("I" &
    lRow2).Value + 1
    End If
    On Error GoTo 0
    End If
    Next c
    End If

    wsResult.Columns("E").Clear
    wsResult.Columns("A").Delete

    'Sort the pairs
    With wsResult
    .Columns("A:C").Sort Key1:=.Range("C2"), Order1:=xlDescending
    .Columns("E:H").Sort Key1:=.Range("H2"), Order1:=xlDescending
    End With


    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    End Sub
     
    Guest, Aug 12, 2007
    #5
  6. Paul Black Guest

    Hi Vergel Adriano,

    Thanks VERY much for revised code, it is appreciated.
    I had an idea after I posted my request.
    It would be nice if the code could find the highest number in any of
    the 6 number combinations using something like the Max worksheet
    function and assigning it to a variable like maxVal for example. Then
    we could calculate and list ALL the combinations of Pairs & Triplets
    whether they have appeared or not along with the total occurances for
    each. Obviously some of them will not have appeared as yet so will
    show zero.
    I know there are 1,176 Pairs of combinations for 6 from 49 and 18,424
    Triplets for 6 from 49.
    Would this be easy to do or would it make the processing time to
    produce the results very long?.

    Thanks in Advance.
    All the Best.
    Paul
     
    Paul Black, Aug 12, 2007
    #6
  7. You could take some of your Lotto winnings and buy an Excel
    textbook ;)
     
    David Hilberg, Aug 12, 2007
    #7
  8. Guest Guest

    I'm not sure I understood what you're wanting to do... Perhaps you'll need to
    explain a little further. Are you saying the 6 numbers can be a number from
    1 to 49 and you want to list all possible pairs and triplets? By my
    calculation, there will be 2,401 pairs and 117,649 triplets... The pairs
    won't be much of a problem but the triplets go over 65,000 so it will need to
    be split.. but again, maybe I'm not fully understanding the question..


    Sub test()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim lCount As Long

    lCount = 0
    For i = 1 To 49
    For j = 1 To 49
    lCount = lCount + 1
    Next j
    Next i
    MsgBox lCount & " pairs"

    lCount = 0
    For i = 1 To 49
    For j = 1 To 49
    For k = 1 To 49
    lCount = lCount + 1
    Next k
    Next j
    Next i

    MsgBox lCount & " triplets"

    End Sub
     
    Guest, Aug 13, 2007
    #8
  9. Paul Black Guest

    Hi Vergel Adriano, thanks for the reply.

    Please ignore my previous post. I did some calculations and came to
    the conclusion that there would be no advantage in listing ALL
    combinations of Pairs or Triplets for those that have and haven't
    appeared, especially with consideration to the processing time, which
    I think would be extreme.
    Anyway, I do not have access to Excel for a couple of days so I would
    just like to ask a couple of questions please with regard to your
    following code. I am new to VBA so please be patient with me.


    ( 1 ) If ALL the 6 number combinations are in a sheet named "Input"
    and in Cells "B3:G?" ( I use "G?" because the row number will
    obviously change as more 6 number combinations are entered ), could we
    use instead of ...

    Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

    .... something like ...

    Set rng = Intersect(Worksheets("Input").Range("B3:G" &
    Range("B3").End(xlDown).Row

    .... to set the range for ALL 6 number combinations?. Do we also need
    to "Select" the "Input" sheet somewhere in the code?.

    ( 2 ) What if ...

    Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

    .... or ...

    Set rng = Intersect(Worksheets("Input").Range("B3:G" &
    Range("B3").End(xlDown).Row

    .... has no data, could we insert something like ...

    If rng Is Nothing Then
    Exit Sub

    .... or such like?.

    ( 3 ) Could you please explain what the Dim variables ...

    c
    lRow
    Irow2

    .... actaually do please.

    ( 4 ) What for the Pairs does this actually mean and do please ...

    If c.Column <= 5 Then

    Thanks VERY much in Advance.
    All the Best.
    Paul
     
    Paul Black, Aug 13, 2007
    #9
  10. Guest Guest

    Hi Paul,

    (1) No, you won't need to select or activate the Input sheet. You usually
    can work with a worksheet or range without selecting it. You can try
    something like this:

    With Worksheets("Input")
    Set rng = .Range("B3:G3").End(xlDown)
    End With


    (2) Yes, you can validate if rng has no data. But since you're starting
    with B3:G3, rng will never be equal to Nothing. What you can do is count
    numeric values and if you get anything greater than 0 then it means you have
    some data to work with. Something like this:

    If Application.WorksheetFunction.Count(rng) > 0 Then
    'do something
    End If


    (3) In the code that I gave, c is a range variable that I used to loop
    through the individual cells in the data range, lRow is a Long variable that
    I used to keep track of the next available row in the "Results" worksheet and
    lRow2 is also a Long variable that I used to determine the row number of a
    pair or triplet that already exists in the Results worksheet. If the call to
    the Match worksheetfunction does not result in error, then it means lRow2
    would have the row number in Results for the current pair or triplet being
    tested.

    (4) In the code "If c.Column <= 5", 5 means column E. Because in my
    example, the data is in columns A to F, then I can only have a pair for
    values in columns A to E. If the cell is in column F (i.e., column=6) then,
    the code should not do anything. In your case, since you're doing it for
    data in columns B to G, you'll want to change the 5 to 6 for pairs and use 5
    instead of 4 for triplets.
     
    Guest, Aug 13, 2007
    #10
  11. Paul Black Guest

    Hi Vergel Adriano,

    I have just run your posted code and it is not giving the correct
    results for either Pairs or Triplets. I put 2 combinations in a sheet
    in Cells "A1:F2" which were :-

    1 2 3 4 5 6
    1 2 3 4 5 7

    The results for "Pairs" should be ...

    3 , 6 = 4 Occurances
    5 , 6 = 4 Occurances
    6 , 7 = 4 Occurances
    1 , 5 = 3 Occurances
    2 , 5 = 3 Occurances
    2 , 6 = 3 Occurances
    3 , 5 = 3 Occurances
    3 , 7 = 3 Occurances
    3 , 8 = 3 Occurances
    5 , 7 = 3 Occurances
    6 , 8 = 3 Occurances
    7 , 8 = 3 Occurances
    1 , 2 = 2 Occurances
    1 , 3 = 2 Occurances
    1 , 6 = 2 Occurances
    1 , 7 = 2 Occurances
    2 , 3 = 2 Occurances
    2 , 7 = 2 Occurances
    3 , 4 = 2 Occurances
    4 , 6 = 2 Occurances
    5 , 8 = 2 Occurances
    6 , 9 = 2 Occurances
    7 , 9 = 2 Occurances
    1 , 4 = 1 Occurances
    1 , 8 = 1 Occurances
    1 , 9 = 1 Occurances
    2 , 4 = 1 Occurances
    2 , 8 = 1 Occurances
    2 , 9 = 1 Occurances
    3 , 9 = 1 Occurances
    4 , 5 = 1 Occurances
    4 , 7 = 1 Occurances
    4 , 8 = 1 Occurances
    4 , 9 = 1 Occurances
    5 , 9 = 1 Occurances
    8 , 9 = 1 Occurances

    .... but your code produced ...

    V1 V2 Cnt
    1 2 2
    2 3 2
    3 4 2
    4 5 2
    5 6 1

    .... results.
    I can't work out why the program is not listing ALL the pairs and the
    total occurances.

    Thanks for your help.
    All the Best.
    Paul
     
    Paul Black, Aug 14, 2007
    #11
  12. Dave D-C Guest

    me too
    How can 1,9 be a pair occurance when there is no 9?
     
    Dave D-C, Aug 14, 2007
    #12
  13. Paul Black Guest

    Well spotted Dave D-C,

    The actual results for Pairs should be as follows ...

    1 , 2 = 2 Occurances
    1 , 3 = 2 Occurances
    1 , 4 = 2 Occurances
    1 , 5 = 2 Occurances
    1 , 6 = 1 Occurances
    1 , 7 = 1 Occurances
    2 , 3 = 2 Occurances
    2 , 4 = 2 Occurances
    2 , 5 = 2 Occurances
    2 , 6 = 1 Occurances
    2 , 7 = 1 Occurances
    3 , 4 = 2 Occurances
    3 , 5 = 2 Occurances
    3 , 6 = 1 Occurances
    3 , 7 = 1 Occurances
    4 , 5 = 2 Occurances
    4 , 6 = 1 Occurances
    4 , 7 = 1 Occurances
    5 , 6 = 1 Occurances
    5 , 7 = 1 Occurances
    6 , 7 = 0 Occurances

    .... NOT as previously stated.
    Your code Vergel Adriano produced ...

    V1 V2 Cnt
    1 2 2
    2 3 2
    3 4 2
    4 5 2
    5 6 1

    Thanks in Advance.
    All the Best.
    Paul
     
    Paul Black, Aug 14, 2007
    #13
  14. Guest Guest

    I think this is what you're looking for.

    Sub MostCommonPairAndTriplet()
    Dim rng As Range
    Dim c As Range
    Dim strPair As String
    Dim strTriplet As String
    Dim wsResult As Worksheet
    Dim lRow As Long
    Dim lRow2 As Long
    Dim i As Integer
    Dim j As Integer

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

    If Not rng Is Nothing Then

    'Get the result worksheet
    On Error Resume Next
    Set wsResult = ActiveWorkbook.Worksheets("Results")
    If wsResult Is Nothing Then
    Set wsResult = ActiveWorkbook.Worksheets.Add
    wsResult.Name = "Results"
    Else
    wsResult.UsedRange.Delete
    End If
    'column labels
    With wsResult
    .Range("B1").Value = "Value1"
    .Range("C1").Value = "Value2"
    .Range("D1").Value = "Count"
    .Range("F1").Value = "Value1"
    .Range("G1").Value = "Value2"
    .Range("H1").Value = "Value3"
    .Range("I1").Value = "Count"
    End With
    On Error GoTo 0

    'Find Pairs
    lRow = 2
    For Each c In rng
    If c.Column <= 5 Then
    For i = 1 To 6 - c.Column
    strPair = c.Value & "_" & c.Offset(0, i).Value

    On Error Resume Next
    lRow2 = Application.WorksheetFunction.Match(strPair,
    wsResult.Range("A:A"), False)
    If Err.Number > 0 Then
    wsResult.Range("A" & lRow).Value = strPair
    wsResult.Range("B" & lRow).Value = c.Value
    wsResult.Range("C" & lRow).Value = c.Offset(0,
    i).Value
    wsResult.Range("D" & lRow).Value = 1
    lRow = lRow + 1
    Else
    wsResult.Range("D" & lRow2).Value =
    wsResult.Range("D" & lRow2).Value + 1
    End If
    On Error GoTo 0
    Next i
    End If
    Next c

    'Find Triplets
    lRow = 2
    For Each c In rng
    If c.Column <= 5 Then
    For i = 1 To 6 - c.Column
    For j = 1 To 6 - c.Offset(0, i).Column
    strTriplet = c.Value & "_" & c.Offset(0, i).Value &
    "_" & c.Offset(0, i + j).Value

    On Error Resume Next
    lRow2 =
    Application.WorksheetFunction.Match(strTriplet, wsResult.Range("E:E"), False)
    If Err.Number > 0 Then
    wsResult.Range("E" & lRow).Value = strTriplet
    wsResult.Range("F" & lRow).Value = c.Value
    wsResult.Range("G" & lRow).Value = c.Offset(0,
    i).Value
    wsResult.Range("H" & lRow).Value = c.Offset(0, i
    + j).Value
    wsResult.Range("I" & lRow).Value = 1
    lRow = lRow + 1
    Else
    wsResult.Range("I" & lRow2).Value =
    wsResult.Range("I" & lRow2).Value + 1
    End If
    On Error GoTo 0
    Next j
    Next i
    End If
    Next c
    End If

    wsResult.Columns("E").Clear
    wsResult.Columns("A").Delete

    'Sort the pairs
    With wsResult
    .Columns("A:C").Sort Key1:=.Range("C2"), Order1:=xlDescending
    .Columns("E:H").Sort Key1:=.Range("H2"), Order1:=xlDescending
    End With


    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    End Sub
     
    Guest, Aug 14, 2007
    #14
  15. Paul Black Guest

    Thanks Vergel Adriano,

    It is almost there.
    I ran your code this morning and it does indeed produce only the
    combinations that are relevant. The only thing is that it is not
    totally properly. It shows a count of 1 for all the combinations where
    some should be 2. I think it is calculating the totals purely on the
    first combination and then going onto the second combination, but
    there are the same combinations in both so the total should be 2.

    Thanks again for all your help and time on this, it is very much
    appreciated.
    All the Best.
    Paul
     
    Paul Black, Aug 15, 2007
    #15
  16. Guest Guest

    Paul,

    I used the sample data that you gave and the code produced the same result
    that you identified. So, with this data in A1:F2:

    1 2 3 4 5 6
    1 2 3 4 5 7

    can you tell me for which pair the code is giving a count of 1 but should be
    2?
     
    Guest, Aug 15, 2007
    #16
  17. Paul Black Guest

    Hi Vergel Adriano,

    It comes up with an ERROR on the line ...

    wsResult.Range("D" & lRow2).Value =wsResult.Range("D" & lRow2).Value 1

    .... for both Pairs & Triplets, but if you remove the 1 at the end it
    appears to be OK.

    Your program for combinations ...

    1 2 3 4 5 6
    1 2 3 4 5 7

    .... produces the results ...

    1 , 2 = 1
    1 , 3 = 1
    1 , 4 = 1
    1 , 5 = 1
    1 , 6 = 1
    2 , 3 = 1
    2 , 4 = 1
    2 , 5 = 1
    2 , 6 = 1
    3 , 4 = 1
    3 , 5 = 1
    3 , 6 = 1
    4 , 5 = 1
    4 , 6 = 1
    5 , 6 = 1
    1 , 7 = 1
    2 , 7 = 1
    3 , 7 = 1
    4 , 7 = 1
    5 , 7 = 1

    .... where it should be ...

    1 , 2 = 2
    1 , 3 = 2
    1 , 4 = 2
    1 , 5 = 2
    1 , 6 = 1
    2 , 3 = 2
    2 , 4 = 2
    2 , 5 = 2
    2 , 6 = 1
    3 , 4 = 2
    3 , 5 = 2
    3 , 6 = 1
    4 , 5 = 2
    4 , 6 = 1
    5 , 6 = 1
    1 , 7 = 1
    2 , 7 = 1
    3 , 7 = 1
    4 , 7 = 1
    5 , 7 = 1

    .... because some Pairs are in BOTH combinations. This would obviously
    be more if there were more than 2 combinations to evaluate.

    Thanks in Advance.
    All the Best.
    Paul
     
    Paul Black, Aug 15, 2007
    #17
  18. Guest Guest

    hmmn.. not sure what happened, but I think I see the problem. The line that
    you identified is the line where the count is incremented by 1. But somehow
    the "+" operator got left out. Those lines should be like this:

    For the pairs:

    wsResult.Range("D" & lRow2).Value =wsResult.Range("D" & lRow2).Value + 1


    For the triplets:

    wsResult.Range("I" & lRow2).Value = wsResult.Range("I" & lRow2).Value + 1
     
    Guest, Aug 15, 2007
    #18
  19. Paul Black Guest

    Hi Vergel Adriano,

    Excellent, it works like a dream.
    One final point, honestly, how would I get it to calculate singles
    please.
    Thanks for ALL your help, time & patience with regard to this, it is
    appreciated.

    Thanks in Advance.
    All the VERY Best.
    Paul
     
    Paul Black, Aug 16, 2007
    #19
  20. Paul Black Guest

    Sorry Vergel Adriano,

    I tried applying the logic to produce Quadruples but I can't seem to
    get it to work.

    Thanks in Advance.
    All the Best.
    Paul
     
    Paul Black, Aug 16, 2007
    #20
    1. Advertisements

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments (here). After that, you can post your question and our members will help you out.