You are on the Home/Other Tutorials/Project Euler/Problem 52 page
Web This Site

Project Euler - Problem 52

More about Project Euler.

Problem description

It can be seen that the number, 125874, and its double, 251748, contain exactly the same digits, but in a different order.

Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, contain the same digits.


For any number of digits that we check, the range of numbers will be quite limited since both x and 6x must have the same number of digits.  So, for example, if we are examining numbers that are 4 digits in length, the range to examine is 1000 to 1666 since anything more will yield a 5 digit value for 6x.

Also, while we are examining the numbers x, 2x, 3x,..., 6x, we can stop examining the numbers as soon as we get the first mismatch.

The code below incorporates both of these "short cuts."

There is some ambiguity in the problem statement in that I don't know if a number can have the same digits repeat.  I assumed that in such an instance the number of occurrences have to match.  The way I implemented the digit examination is through a 10 element array where the index of each element represented the digits 0 through 9.  So, if a digit in a number is a 1, the value of the corresponding element is incremented by one.  Once each number has had its digits analyzed in this manner one can compare this array with the array containing the digits of the previous number.   If the requirements of the problem are satisfied, every array element must have the same value. 

    Function IsSame(Eles() As Byte, Idx1 As Integer, Idx2 As Integer) As Boolean
        Dim I As Integer
        IsSame = True
        For I = LBound(Eles, 2) To UBound(Eles, 2)
            IsSame = IsSame And Eles(Idx1, I) = Eles(Idx2, I)
            If Not IsSame Then Exit Function
            Next I
        End Function
    Function SameString(ParamArray X()) As Boolean
        Dim I As Integer, Eles() As Byte
        ReDim Eles(UBound(X) - LBound(X) + 1, 9)
        For I = LBound(X) To UBound(X)
            Dim aVal As Long
            aVal = X(I)
            Do While aVal > 0
                Dim aDigit As Integer
                aDigit = aVal Mod 10: aVal = aVal \ 10
                Eles(I, aDigit) = Eles(I, aDigit) + 1
            If I > LBound(X) Then If Not IsSame(Eles(), I, I - 1) Then _
                SameString = False: Exit Function
            Next I
        SameString = True
        End Function
Sub Euler052()
    Dim X As Long, ProcTime As Single
    ProcTime = Timer
    Dim NbrDigits As Integer
    NbrDigits = 0
        NbrDigits = NbrDigits + 1
        Dim HighLim As Long
        X = 10 ^ (NbrDigits - 1)
        HighLim = Int(10 ^ (NbrDigits) / 6)
        Dim MatchFound As Boolean
            MatchFound = SameString(X, 2 * X, 3 * X, 4 * X, 5 * X, 6 * X)
            If Not MatchFound Then X = X + 1
            Loop Until MatchFound Or X > HighLim
        Loop Until MatchFound   'If we trust the Project Euler website, we know there is a solution
    Debug.Print X, Timer - ProcTime
    End Sub