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
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
I'm a bit confused by your explanation, but I THINK you're looking to do two things:
1) find the unique values in your list
and
2) count the number of times each unique element occurs in said list.

Try this code. It does three things:
- it assumes your list is in column A
- lists in Column B "Elements" (unique values)
- counts the frequency of each element in column C "Frequency of Elements".

Code: 
Sub uniques()
Dim i As Integer
Dim Lastrow As Integer
Dim Arange As Range


Lastrow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Set Arange = Range("A1:A" & Lastrow)
Arange.Copy
Range("B1").Select
ActiveSheet.Paste
Range("B1").Select
Range("B1:B" & Lastrow).Select
With Selection
    .RemoveDuplicates Columns:=1, Header:=xlYes
    .Sort key1:=Range("B1"), Header:=xlYes
End With
Range("B1") = "Elements"
Range("C1") = "Frequency of Elements"


Dim LastB As Integer
LastB = ActiveSheet.Cells(1, 2).End(xlDown).Row
'//LastB must be calculated after dups removed
Range("B2").Select
For i = 2 To LastB
    Range("B" & i).Select
        Selection.Offset(0, 1) = WorksheetFunction.CountIf(Arange, ActiveCell)
Next i




End Sub
 
Upvote 0
Thanks for a quick reply, but that's not what I am looking for.

I need to find consecutive pairs, triplets, quintuplets, quadruplets in one column, starting from bottom to top.

So how many times continuous string of numbers repeat in on column starting from bottom to top.

Starting with first two numbers at the bottom, finding repeat in the column, then going up by one row then,

starting with first three numbers at the bottom,find how many times repeats, then going up by on row, and so on.

I only need it at least for a pair then I can change the code to find the rest.
 
Last edited:
Upvote 0
There's a workbook at https://app.box.com/s/y6u22zry3beebdnnqqd7 that will generate this output:

[Table="width:, class:grid"][tr][td]Row\Col[/td][td]
C​
[/td][td]
D​
[/td][td]
E​
[/td][td]
F​
[/td][td]
G​
[/td][td]
H​
[/td][td]
I​
[/td][td]
J​
[/td][td]
K​
[/td][/tr][tr][td]
2​
[/td][td][/td][td][/td][td]
# Rpts​
[/td][td]
4​
[/td][td]
4​
[/td][td]
2​
[/td][td]
2​
[/td][td]
2​
[/td][td]
2​
[/td][/tr]
[tr][td]
3​
[/td][td]
rgnInp​
[/td][td][/td][td]
Length​
[/td][td]
3​
[/td][td]
4​
[/td][td]
5​
[/td][td]
6​
[/td][td]
7​
[/td][td]
8​
[/td][/tr]
[tr][td]
4​
[/td][td]
5​
[/td][td][/td][td][/td][td][/td][td]
5​
[/td][td][/td][td][/td][td][/td][td]
5​
[/td][/tr]
[tr][td]
5​
[/td][td]
9​
[/td][td][/td][td][/td][td]
9​
[/td][td]
9​
[/td][td][/td][td][/td][td]
9​
[/td][td]
9​
[/td][/tr]
[tr][td]
6​
[/td][td]
1​
[/td][td][/td][td][/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][/tr]
[tr][td]
7​
[/td][td]
3​
[/td][td][/td][td][/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][/tr]
[tr][td]
8​
[/td][td]
5​
[/td][td][/td][td][/td][td][/td][td]
5​
[/td][td]
5​
[/td][td]
5​
[/td][td]
5​
[/td][td]
5​
[/td][/tr]
[tr][td]
9​
[/td][td]
9​
[/td][td][/td][td][/td][td]
9​
[/td][td]
9​
[/td][td]
9​
[/td][td]
9​
[/td][td]
9​
[/td][td]
9​
[/td][/tr]
[tr][td]
10​
[/td][td]
1​
[/td][td][/td][td][/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][/tr]
[tr][td]
11​
[/td][td]
3​
[/td][td][/td][td][/td][td]
3​
[/td][td]
3​
[/td][td][/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][/tr]
[tr][td]
12​
[/td][td]
5​
[/td][td][/td][td][/td][td][/td][td]
5​
[/td][td][/td][td][/td][td][/td][td]
5​
[/td][/tr]
[tr][td]
13​
[/td][td]
9​
[/td][td][/td][td][/td][td]
9​
[/td][td]
9​
[/td][td][/td][td][/td][td]
9​
[/td][td]
9​
[/td][/tr]
[tr][td]
14​
[/td][td]
1​
[/td][td][/td][td][/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][/tr]
[tr][td]
15​
[/td][td]
3​
[/td][td][/td][td][/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][/tr]
[tr][td]
16​
[/td][td]
5​
[/td][td][/td][td][/td][td][/td][td]
5​
[/td][td]
5​
[/td][td]
5​
[/td][td]
5​
[/td][td]
5​
[/td][/tr]
[tr][td]
17​
[/td][td]
9​
[/td][td][/td][td][/td][td]
9​
[/td][td]
9​
[/td][td]
9​
[/td][td]
9​
[/td][td]
9​
[/td][td]
9​
[/td][/tr]
[tr][td]
18​
[/td][td]
1​
[/td][td][/td][td][/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][td]
1​
[/td][/tr]
[tr][td]
19​
[/td][td]
3​
[/td][td][/td][td][/td][td]
3​
[/td][td]
3​
[/td][td][/td][td]
3​
[/td][td]
3​
[/td][td]
3​
[/td][/tr]
[/table]

You can see that 9-1-3 appears 4 times, 5-9-1-3 appears 4 times, 9-1-3-5-9-1-3 appears twice.

The workbook was created for another purpose entirely, but perhaps you can modify it.
 
Last edited:
Upvote 0
From BOTTOM to top? That's opposite of how most formulas work. I have no idea how to help. I suggest Googling for "consecutive duplicates" and see if somebody can help you based on that.

Alternately, could you just use conditional formatting to highlight duplicates and figure it out from there?
 
Upvote 0
FGM666 said:
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]
Click to expand...
Will your numbers always be single digit numbers as your example shows?
 
Upvote 0
shg said:
There's a workbook at https://app.box.com/s/y6u22zry3beebdnnqqd7 that will generate this output:

[TABLE="class: grid"]
<tbody>[TR]
[TD]Row\Col[/TD]
[TD]
C​
[/TD]
[TD]
D​
[/TD]
[TD]
E​
[/TD]
[TD]
F​
[/TD]
[TD]
G​
[/TD]
[TD]
H​
[/TD]
[TD]
I​
[/TD]
[TD]
J​
[/TD]
[TD]
K​
[/TD]
[/TR]
[TR]
[TD]
2​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
# Rpts​
[/TD]
[TD]
4​
[/TD]
[TD]
4​
[/TD]
[TD]
2​
[/TD]
[TD]
2​
[/TD]
[TD]
2​
[/TD]
[TD]
2​
[/TD]
[/TR]
[TR]
[TD]
3​
[/TD]
[TD]
rgnInp​
[/TD]
[TD][/TD]
[TD]
Length​
[/TD]
[TD]
3​
[/TD]
[TD]
4​
[/TD]
[TD]
5​
[/TD]
[TD]
6​
[/TD]
[TD]
7​
[/TD]
[TD]
8​
[/TD]
[/TR]
[TR]
[TD]
4​
[/TD]
[TD]
5​
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]
5​
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]
5​
[/TD]
[/TR]
[TR]
[TD]
5​
[/TD]
[TD]
9​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[/TR]
[TR]
[TD]
6​
[/TD]
[TD]
1​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[/TR]
[TR]
[TD]
7​
[/TD]
[TD]
3​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[/TR]
[TR]
[TD]
8​
[/TD]
[TD]
5​
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]
5​
[/TD]
[TD]
5​
[/TD]
[TD]
5​
[/TD]
[TD]
5​
[/TD]
[TD]
5​
[/TD]
[/TR]
[TR]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[/TR]
[TR]
[TD]
10​
[/TD]
[TD]
1​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[/TR]
[TR]
[TD]
11​
[/TD]
[TD]
3​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD][/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[/TR]
[TR]
[TD]
12​
[/TD]
[TD]
5​
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]
5​
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]
5​
[/TD]
[/TR]
[TR]
[TD]
13​
[/TD]
[TD]
9​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[/TR]
[TR]
[TD]
14​
[/TD]
[TD]
1​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[/TR]
[TR]
[TD]
15​
[/TD]
[TD]
3​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[/TR]
[TR]
[TD]
16​
[/TD]
[TD]
5​
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]
5​
[/TD]
[TD]
5​
[/TD]
[TD]
5​
[/TD]
[TD]
5​
[/TD]
[TD]
5​
[/TD]
[/TR]
[TR]
[TD]
17​
[/TD]
[TD]
9​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[TD]
9​
[/TD]
[/TR]
[TR]
[TD]
18​
[/TD]
[TD]
1​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[TD]
1​
[/TD]
[/TR]
[TR]
[TD]
19​
[/TD]
[TD]
3​
[/TD]
[TD][/TD]
[TD][/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD][/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[TD]
3​
[/TD]
[/TR]
</tbody>[/TABLE]


You can see that 9-1-3 appears 4 times, 5-9-1-3 appears 4 times, 9-1-3-5-9-1-3 appears twice.

The workbook was created for another purpose entirely, but perhaps you can modify it.
Click to expand...

Sort of what I am looking for but VBA code would be greatly appriciated :D
 
Upvote 0
Rick Rothstein said:
Will your numbers always be single digit numbers as your example shows?
Click to expand...
FGM666 said:
yes
Click to expand...
Does this code do what you want...
[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
        Cells(Rows.Count, "C").End(xlUp).Offset(-(X > 0)) = K(X)
        Cells(Rows.Count, "D").End(xlUp).Offset(-(X > 0)) = .Item(K(X))
      Next
      .RemoveAll
    End With
  Next
End Sub
[/td]
[/tr]
[/table]
 
Last edited:
  • Like
Reactions: shg
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