Strange Numbers
Ratings: 
(No Ratings Yet)
Loading...
DESCRIPTION:
Find any combination numbers that have the result contain all the numbers. Example:
142857 = 142857 X 1
285714 = 142857 X 2
428571 = 142857 X 3
571428 = 142857 X 4
714285 = 142857 X 5
857142 = 142857 X 6
Redim With Preserve keyword
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | Sub StrangeNumbers() Dim a As Long Dim Maxno As Long Dim StartNo As Long Dim Result As Long Dim d As Integer Dim i As Integer Dim ctr As Integer Dim ii As Integer Dim lastrow As Integer ' StartNo = UserForm1.TextBox3 Maxno = UserForm1.TextBox4 'Process each X Number until max number For a = StartNo To Maxno ctr = 0 'Take the X Number and multiple by multiplier until 6 loop For i = 1 To 6 Result = a * i d = Len(CStr(Result)) 'check if the result contains the X numbers FoundMatchingNumber = FindTheMatching(d, CStr(Result), CStr(a)) If FoundMatchingNumber = d Then ctr = ctr + 1 End If Next i 'if Found counter = 6 then display X number If ctr = 6 Then lastrow = Cells(Rows.Count, "A").End(xlUp).Row lastrow = lastrow + 1 For ii = 1 To 6 Cells(lastrow + ii, 1) = a Cells(lastrow + ii, 2) = ii Cells(lastrow + ii, 3) = a * ii Next ii End If Next a MsgBox "done" End Sub Function FindTheMatching(Multiplier_MAX As Integer, StringTobeSearch As String, StringResult As String) As Integer Dim aa As Integer aa = 0 For i = 1 To Multiplier_MAX chartobesearch = Mid(StringTobeSearch, i, 1) a = InStr(1, StringResult, chartobesearch, vbTextCompare) If a > 0 Then StringResult = Replace(StringResult, chartobesearch, "", 1, 1) aa = aa + 1 End If Next i FindTheMatching = aa End Function |
Output:
StrangeNumber
1 file(s) 26.07 KB