VBA To check for pairs in a column.

F

FGM666

New Member
Joined
Aug 31, 2015
Messages
13
Hi I got a column of numbers i.e. :

[TABLE="width: 64"]
<colgroup><col></colgroup><tbody>[TR]
[TD]5[/TD]
[/TR]
[TR]
[TD]9[/TD]
[/TR]
[TR]
[TD]1[/TD]
[/TR]
[TR]
[TD]3[/TD]
[/TR]
[TR]
[TD]5[/TD]
[/TR]
[TR]
[TD]9[/TD]
[/TR]
[TR]
[TD]1[/TD]
[/TR]
[TR]
[TD]3[TABLE="width: 64"]
<colgroup><col></colgroup><tbody>[TR]
[TD]5[/TD]
[/TR]
[TR]
[TD]9[/TD]
[/TR]
[TR]
[TD]1[/TD]
[/TR]
[TR]
[TD]3[/TD]
[/TR]
[TR]
[TD]5[/TD]
[/TR]
[TR]
[TD]9[/TD]
[/TR]
[TR]
[TD]1[/TD]
[/TR]
[TR]
[TD]3[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]


Starting from the bottom I want to count and then display results in columns so say :
Row Cells
A B C
1. 3 1 = 4
2. 1 9 = 4
.......... and so on


I want to do it for triplets and so on.
Row Cells
A B C D
1. 3 1 9 = 4
2. 1 9 5 = 4
3. 9 5 3 = 3


They have to be consecutive, with no gaps. So no


3 9 5 = 4

Thanks for anyone who can help.

I got this code as well, I didn't write it just upgraded it.
It counts pairs but in consecutive rows of five numbers in five consecutive columns.
Any way to modify it to do what I want would be of great help, thank you.

Code: 
'=== copy from here ================================='- MACRO TO COUNT PAIRS OF NUMBERS.
'- Numbers contained in a sheet called "Sheet1" ...
'- Columns B to G starting row 2.
'- Needs another blank sheet called "Results"
'- Brian Baulsom August 2004
'====================================================
Dim FromSheet As Worksheet
Dim ToSheet As Worksheet
Dim TempSheet As Worksheet
Dim Fromrow As Long
Dim ToRow As Long
Dim LastRow As Long
Dim Counter As Long
Dim FoundCell As Object
'-
Dim N1 As Integer
Dim N2 As Integer
Dim N3 As Integer
Dim N4 As Integer
Dim N5 As Integer


Dim N1a As Integer
Dim N2a As Integer
Dim N3a As Integer
Dim N4a As Integer
Dim N5a As Integer


'-
Dim CheckStr1 As String
Dim CheckStr2 As String
Dim CheckStr3 As String
Dim CheckStr4 As String
Dim CheckStr5 As String
Dim CheckStr6 As String
Dim CheckStr7 As String
Dim CheckStr8 As String




'------------------------
Sub FindDupes_Click()
Set FromSheet = Worksheets("Sheet1")
    LastRow = FromSheet.Range("A65536").End(xlUp).Row
Set TempSheet = Worksheets("TempSheet")
    TempSheet.Range("A:Z").ClearContents
Set ToSheet = Worksheets("Results2")
    ToSheet.Range("A:Z").ClearContents
    Fromrow = 2
    ToRow = 1
    '-----------------------
    '- main loop
    '
    '-----------------------
    ' Dla Rzedow od
    For Fromrow = 1 To LastRow
    
    
        Application.StatusBar = _
            "  Processing row : " & Fromrow & " / " & LastRow
        For A = 2 To 6
            N1 = FromSheet.Cells(Fromrow, A).Value
                For B = A + 1 To 6
                    N2 = FromSheet.Cells(Fromrow, B).Value
                    
                    '- Sprawdz ciag z kratek
                        
                    CheckStr1 = Format(N1, "00") & " - " & Format(N2, "00")
                    Counter = 1
                
                    CheckOtherRows2
                
                        If Counter > 1 Then
                        TempSheet.Cells(ToRow, 1).Value = "'" & CheckStr1
                        TempSheet.Cells(ToRow, 2).Value = Counter
                        ToSheet.Cells(ToRow, 1).Value = N1
                        ToSheet.Cells(ToRow, 2).Value = N2
                        ToSheet.Cells(ToRow, 3).Value = Counter
                        ToRow = ToRow + 1
                        End If
                Next
                
                For B = A + 1 To 6
                    N2 = FromSheet.Cells(Fromrow, B).Value
                        For c = B + 1 To 6
                            N3 = FromSheet.Cells(Fromrow, c).Value
                
                            '- Sprawdz ciag z kratek
                
                            CheckStr3 = Format(N1, "00") & " - " & Format(N2, "00") & " - " & Format(N3, "00")
                            
                                    
                            CheckOtherRows3
        
                                If Counter > 1 Then
                                TempSheet.Cells(ToRow, 3).Value = "'" & CheckStr3
                                TempSheet.Cells(ToRow, 4).Value = Counter
                                ToSheet.Cells(ToRow, 5).Value = N1
                                ToSheet.Cells(ToRow, 6).Value = N2
                                ToSheet.Cells(ToRow, 7).Value = N3
                                ToSheet.Cells(ToRow, 8).Value = Counter
                                ToRow = ToRow + 1
                                End If
                        Next
                        
                        For c = B + 1 To 6
                            N3 = FromSheet.Cells(Fromrow, c).Value
                                For d = c + 1 To 6
                                    N4 = FromSheet.Cells(Fromrow, d).Value
                                        
                                    '- Sprawdz ciag z kratek
                
                                    CheckStr5 = Format(N1, "00") & " - " & Format(N2, "00") & " - " & Format(N3, "00") & " - " & Format(N4, "00")
                                    
                        
                                    CheckOtherRows4
                                        
                                        If Counter > 1 Then
                                        TempSheet.Cells(ToRow, 5).Value = "'" & CheckStr5
                                        TempSheet.Cells(ToRow, 6).Value = Counter
                                        ToSheet.Cells(ToRow, 10).Value = N1
                                        ToSheet.Cells(ToRow, 11).Value = N2
                                        ToSheet.Cells(ToRow, 12).Value = N3
                                        ToSheet.Cells(ToRow, 13).Value = N4
                                        ToSheet.Cells(ToRow, 14).Value = Counter
                                        ToRow = ToRow + 1
                                        End If
                                Next
                                
                                For d = c + 1 To 6
                                    N4 = FromSheet.Cells(Fromrow, d).Value
                                        For e = d + 1 To 6
                                            N5 = FromSheet.Cells(Fromrow, e).Value
                                            
                                            '- Sprawdz ciag z kratek
                
                                            CheckStr7 = Format(N1, "00") & " - " & Format(N2, "00") & " - " & Format(N3, "00") & " - " & Format(N4, "00") & " - " & Format(N5, "00")
                                            
        
                                            CheckOtherRows5
                                            
                                                If Counter > 1 Then
                                                TempSheet.Cells(ToRow, 7).Value = "'" & CheckStr7
                                                TempSheet.Cells(ToRow, 8).Value = Counter
                                                ToSheet.Cells(ToRow, 16).Value = N1
                                                ToSheet.Cells(ToRow, 17).Value = N2
                                                ToSheet.Cells(ToRow, 18).Value = N3
                                                ToSheet.Cells(ToRow, 19).Value = N4
                                                ToSheet.Cells(ToRow, 20).Value = N5
                                                ToSheet.Cells(ToRow, 21).Value = Counter
                                                ToRow = ToRow + 1
                                                End If
                                        Next


Next
                        Next
                Next
        
    Next
    Next
    '-- sort results
    Sort1
    Sort2
    Sort3
    Sort4
    MsgBox ("Done.")
    Application.StatusBar = False
End Sub
'-----------------------------------------------------------------
Sub CheckOtherRows2()
    '- check previous results for duplicate set
    Set FoundCell = TempSheet.Columns(1).Find(what:=CheckStr1, lookat:=xlPart)
    '- Not found - then look for matches in following rows
    If FoundCell Is Nothing Then
        Counter = 1
        
        For rw = Fromrow + 1 To LastRow
        
        For x = 2 To 6
            N1a = FromSheet.Cells(rw, x).Value
                For y = x + 1 To 6
                    N2a = FromSheet.Cells(rw, y).Value
                    
                    CheckStr2 = Format(N1a, "00") & " - " & Format(N2a, "00")
                    
                        '- match found - increment counter
                        If CheckStr1 = CheckStr2 Then
                        Counter = Counter + 1
                        End If
                Next
        Next
        Next
    End If
End Sub
'=== copy to here =================================================


'-----------------------------------------------------------------
Sub CheckOtherRows3()
    '- check previous results for duplicate set
    Set FoundCell = TempSheet.Columns(1).Find(what:=CheckStr3, lookat:=xlPart)
    
    '- Not found - then look for matches in following rows
    
    If FoundCell Is Nothing Then
        Counter = 1
        
        For rw = Fromrow + 1 To LastRow
        
        For x = 2 To 6
            N1a = FromSheet.Cells(rw, x).Value
                For y = x + 1 To 6
                    N2a = FromSheet.Cells(rw, y).Value
                        For Z = y + 1 To 6
                            N3a = FromSheet.Cells(rw, Z).Value
        
                            CheckStr4 = Format(N1a, "00") & " - " & Format(N2a, "00") & " - " & Format(N3a, "00")
        
                                '- match found - increment counter
                                If CheckStr3 = CheckStr4 Then
                                Counter = Counter + 1
                                End If
                        Next
                Next
        Next
        Next
    End If
End Sub
'=== copy to here =================================================


Sub CheckOtherRows4()
    '- check previous results for duplicate set
    Set FoundCell = TempSheet.Columns(1).Find(what:=CheckStr5, lookat:=xlPart)
    
    '- Not found - then look for matches in following rows
    
    If FoundCell Is Nothing Then
        Counter = 1
        
        For rw = Fromrow + 1 To LastRow
        
        For x = 2 To 6
            N1a = FromSheet.Cells(rw, x).Value
                For y = x + 1 To 6
                    N2a = FromSheet.Cells(rw, y).Value
                        For Z = y + 1 To 6
                            N3a = FromSheet.Cells(rw, Z).Value
                                For S = Z + 1 To 6
                                    N4a = FromSheet.Cells(rw, S).Value
        
                                    CheckStr6 = Format(N1a, "00") & " - " & Format(N2a, "00") & " - " & Format(N3a, "00") & " - " & Format(N4a, "00")
        
                                        '- match found - increment counter
                                        If CheckStr5 = CheckStr6 Then
                                        Counter = Counter + 1
                                        End If
                                Next
                        Next
                Next
        Next
        Next
    End If
End Sub


'=== copy to here =================================================
Sub CheckOtherRows5()
    '- check previous results for duplicate set
    Set FoundCell = TempSheet.Columns(1).Find(what:=CheckStr7, lookat:=xlPart)
    
    '- Not found - then look for matches in following rows
    
    If FoundCell Is Nothing Then
        Counter = 1
        
        For rw = Fromrow + 1 To LastRow
        
        For x = 2 To 6
            N1a = FromSheet.Cells(rw, x).Value
                For y = x + 1 To 6
                    N2a = FromSheet.Cells(rw, y).Value
                        For Z = y + 1 To 6
                            N3a = FromSheet.Cells(rw, Z).Value
                                For S = Z + 1 To 6
                                    N4a = FromSheet.Cells(rw, S).Value
                                        For q = S + 1 To 6
                                            N5a = FromSheet.Cells(rw, q).Value
        
                                            CheckStr8 = Format(N1a, "00") & " - " & Format(N2a, "00") & " - " & Format(N3a, "00") & " - " & Format(N4a, "00") & " - " & Format(N5a, "00")
        
                                                '- match found - increment counter
                                                If CheckStr7 = CheckStr8 Then
                                                Counter = Counter + 1
                                                End If
                                         Next
                                Next
                        Next
                Next
        Next
        Next
    End If
End Sub
'=== copy to here =================================================


Sub Sort1()
    ToSheet.UsedRange.Columns("A:C").Sort Key1:=Range("C1"), Key2:=Range("A1:B1"), Order1:=xlDescending, Order2:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
    
Sub Sort2()
    ToSheet.UsedRange.Columns("E:H").Sort Key1:=Range("H1"), Key2:=Range("E1:F1:G1"), Order1:=xlDescending, Order2:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub


Sub Sort3()
    ToSheet.UsedRange.Columns("I:M").Sort Key1:=Range("M1"), Key2:=Range("I1:J1:K1:L1"), Order1:=xlDescending, Order2:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub


Sub Sort4()
    ToSheet.UsedRange.Columns("N:S").Sort Key1:=Range("S1"), Key2:=Range("N1:O1:P1:Q1:R1"), Order1:=xlDescending, Order2:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
 
Sort by date Sort by votes
Thanks mate, it's exactly what I was looking for :D Thank you ever so much I can modify it to do my bidding now. Helped me a lot, will use it to learn more VBA with it. Thank you.
 
Upvote 0

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
FGM666 said:
One more thing how to make it not pint single results. Those that occur only one time :D
Click to expand...
This should do it...
[table="width: 500"]
[tr]
[td]
Code: 
Sub MultiCountsFromBottom()
  Dim X As Long, HowMany As Long, Nums As String, Rng As Range, K As Variant
  Set Rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  Nums = " " & StrReverse(Join(Application.Transpose(Rng))) & " "
  Columns("C:D").Clear
  For HowMany = 2 To Int(Rng.Count / 2)
    With CreateObject("Scripting.Dictionary")
      For X = 1 To HowMany * Int(Len(Nums) / HowMany) / 2 Step 2
        .Item(Trim(Mid(Nums, X, 2 * HowMany + 1))) = UBound(Split(Nums, Mid(Nums, X, 2 * HowMany + 1)))
      Next
      K = .Keys
      For X = 0 To .Count - 1
        If .Item(K(X)) > 1 Then
          Cells(Rows.Count, "C").End(xlUp).Offset(-(X > 0)) = K(X)
          Cells(Rows.Count, "D").End(xlUp).Offset(-(X > 0)) = .Item(K(X))
        End If
      Next
      .RemoveAll
    End With
  Next
End Sub
[/td]
[/tr]
[/table]
 
Upvote 0
:D Thanks

I just realized that it would be useful to have it count's long digits like 234 in one column.

I know you asked about it at first but I didn't think I would need it :(

So converting cells to strings would be required I suppose.
 
Last edited:
Upvote 0
FGM666 said:
I just realized that it would be useful to have it count's long digits like 234 in one column.

I know you asked about it at first but I didn't think I would need it :(

So converting cells to strings would be required I suppose.
Click to expand...
No, it will take a complete rewrite of the code (which is why I asked)... the code I posted takes advantage of the fact that each number is a single digit. I have something to do for a few hours coming up tonight, so I'll see what I can do for you later on tonight or tomorrow depending on how my time goes.

Just checking, though... you are talking about 1, 2 and 3 digit numbers, not just three digit number only, correct?
 
Upvote 0
Rick Rothstein said:
No, it will take a complete rewrite of the code (which is why I asked)... the code I posted takes advantage of the fact that each number is a single digit. I have something to do for a few hours coming up tonight, so I'll see what I can do for you later on tonight or tomorrow depending on how my time goes.

Just checking, though... you are talking about 1, 2 and 3 digit numbers, not just three digit number only, correct?
Click to expand...

Yes

1
22
34
4
567
23
122

Thanks in advance and sorry for the trouble.

I will use both codes and will analyze them to try to learn from them as well, so your work is not entirely wasted. There is no rush with it neither, you're of a great help and I appreciate it a lot. Man you're a GOD to me right now.
 
Upvote 0
@Rick Rothstein;

In your code if a pair is next to each other, it is not getting counted. For example,

[TABLE="width: 64"]
<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64, align: right"]8[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[/TR]
</tbody>[/TABLE]

In this 3,4 is coming 5 times (and at one instance the pair is next to each other, ie, 3 4 3 4) but is getting counted as 4 times.

Can the code to adjusted?
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
VBA to check if worksheet exists
Replies
8
Views
314
bdt
B
C
  • Solved
Need Help VBA
2
Replies
10
Views
427
Trebor76
T
Noid67
  • Question Question
Multiple worksheet change and Formula use
2
Replies
17
Views
713
mumps
mumps
S
  • Question Question
VBA to ignore certain MAC Address values but process all others
Replies
1
Views
566
myall_blues
myall_blues
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
813
Agnarr
Agnarr

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,636
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top