Search for 3 digit number in a four digit number

Hi everyone,

Can anyone please create a VBA code to search a 3 digit number in many four digit numbers and count how many that are there? Let me explain more descriptively, in my worksheet, there are many 4 digit numbers, and I want to know how much times a certain 3 digit number appeared in my worksheet. In 1234, there is, 123,124,134,234, right? Okay, so if I want to search for like a 234 in my worksheet, the computer should recognize 1234, or 4321 or 4123 or any number that have 234(in any order like 432,342, and so on) and count how many are there. Please help. Here is one small part of my worksheet.

Hi Jbeaucaire,

I can't seem to make it work, can you please apply it to the attached file in post 1, and attached it for me, please? Thank you.

Don't understand why "4054" in Yellow counts for "434".

Option Explicit

Sub test()
    Dim myNumbers, e, i As Long, x, y
    myNumbers = VBA.Array(VBA.Array(434, 0), VBA.Array(663, 0))
    With Cells(1).CurrentRegion
        For i = 0 To UBound(myNumbers)
            x = mySort(myNumbers(i)(0))
            If IsArray(x) Then
                For Each e In .Value
                    y = mySort(e)
                    If IsArray(y) Then
                        If Join$(y, "") Like "*" & Join$(x, "*") & "*" Then
                            myNumbers(i)(1) = myNumbers(i)(1) + 1
                        End If
                    End If
                Next
            End If
        Next
        With .Offset(, .Columns.Count + 2).Resize(1, 2)
            .CurrentRegion.ClearContents
            .Value = [{"Numbwer","Appearance"}]
            .Offset(1).Resize(UBound(myNumbers) + 1).Value = _
            Application.Transpose(Application.Transpose(myNumbers))
        End With
    End With
End Sub

Private Function mySort(txt)
    Dim a, i As Long, ii As Long, temp
    If Len(txt) > 1 Then
        a = Split(StrConv(txt, 64), Chr(0))
        ReDim Preserve a(UBound(a) - 1)
        For i = LBound(a) To UBound(a) - 1
            For ii = i + 1 To UBound(a)
                If a(i) > a(ii) Then
                    temp = a(i)
                    a(i) = a(ii)
                    a(ii) = temp
                End If
            Next
        Next
        mySort = a
    ElseIf Len(txt) = 1 Then
        mySort = VBA.Array(txt)
    Else
        mySort = Empty
    End If
End Function

Option Explicit
Sub Tim3So()
 Dim Jj As Byte, Num As Integer, Tr As Byte, Ch As Byte, DV As Byte
 ReDim Arr(1 To 6)
 Dim Rng As Range, sRng As Range
 Dim MyAdd As String
 
 Num = InputBox("ENTER xyz < 433", "GPE.COM", 432)
 If Num > 433 Or Num < 123 Then Exit Sub
 Tr = Num \ 100
 Ch = (Num \ 10) Mod 10
 DV = Num Mod 10
 Arr(1) = Num
 Arr(2) = Ch * 100 + Tr * 10 + DV
 Arr(3) = Ch * 100 + Tr + DV * 10
 Arr(4) = DV * 100 + Tr * 10 + Ch
 Arr(5) = DV * 100 + Ch * 10 + Tr
 Arr(6) = Tr * 100 + DV * 10 + Ch
 Set Rng = ActiveSheet.UsedRange
 Rng.Interior.ColorIndex = 0
 For Jj = 1 To 6
    Set sRng = Rng.Find(Arr(Jj), , xlFormulas, xlPart)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            sRng.Interior.ColorIndex = 34 + Jj
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
 Next Jj
End Sub

Sorry, it was my mistake that the 4504 was highlighted. It shouldn't be.

Originally Posted by Jerry HKA

Sorry, it was my mistake that the 4504 was highlighted. It shouldn't be.

Is it working or not?

Originally Posted by Jerry HKA

Hi everyone,

Can anyone please create a VBA code to search a 3 digit number in many four digit numbers and count how many that are there? Let me explain more descriptively, in my worksheet, there are many 4 digit numbers, and I want to know how much times a certain 3 digit number appeared in my worksheet. In 1234, there is, 123,124,134,234, right? Okay, so if I want to search for like a 234 in my worksheet, the computer should recognize 1234, or 4321 or 4123 or any number that have 234(in any order like 432,342, and so on) and count how many are there. Please help. Here is one small part of my worksheet.

Option Explicit
Sub Tim3So()
 Dim Jj As Byte, Num As Integer, Tr As Byte, Ch As Byte, DV As Byte
 ReDim Arr(1 To 6)
 Dim Rng As Range, sRng As Range
 Dim MyAdd As String
 
 Num = InputBox("ENTER xyz < 433", "GPE.COM", 432)
 If Num > 433 Or Num < 123 Then Exit Sub
 Tr = Num \ 100
 Ch = (Num \ 10) Mod 10
 DV = Num Mod 10
 Arr(1) = Num
 Arr(2) = Ch * 100 + Tr * 10 + DV
 Arr(3) = Ch * 100 + Tr + DV * 10
 Arr(4) = DV * 100 + Tr * 10 + Ch
 Arr(5) = DV * 100 + Ch * 10 + Tr
 Arr(6) = Tr * 100 + DV * 10 + Ch
 Set Rng = ActiveSheet.UsedRange
 Rng.Interior.ColorIndex = 0
 For Jj = 1 To 6
    Set sRng = Rng.Find(Arr(Jj), , xlFormulas, xlPart)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            sRng.Interior.ColorIndex = 34 + Jj
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
 Next Jj
End Sub

http://www.giaiphapexcel.com/forum/s...7919;-số

To Sa DQ,
I can't seem to make it work. Can you apply it to the attached in post 1. Thank you.

To Jindon,
Why is it only searching for 434 and 663, if it is not the result you got, can you approach the code and make it to search the worksheet, and arrange the numbers from most appeared, to least appeared. Thank you.

To Jbeaucaire,
Can you make the code help me search for many numbers at once, that will help me save time, pleas do try. Thank you

Originally Posted by Jerry HKA

To Jindon,
Why is it only searching for 434 and 663, if it is not the result you got, can you approach the code and make it to search the worksheet, and arrange the numbers from most appeared, to least appeared. Thank you.

I don't understand what you are talking about.
I wrote the code according to your sample file.

What is your question then???

I'm terribly sorry, Jindon,

Your code is only searching for 434 and 663, but I don't only want to find those numbers, there are million of numbers wanted from me. But I only gave the two numbers as an example of the desired result. Please disregards the other written in the post for you.

Or is it my fault of not knowing how to use your code properly, if so, please educate me of what to do.

Originally Posted by Jerry HKA

I'm terribly sorry, Jindon,

Your code is only searching for 434 and 663, but I don't only want to find those numbers, there are million of numbers wanted from me. But I only gave the two numbers as an example of the desired result. Please disregards the other written in the post for you.

Where are they?

Okay, I tanhk you Jindon for helping me out here. I will be needing your help in the future. Thank you, Jbeaucaire, for your help. I really respect you. Thank you for all.