Project Euler - Problem 52

Solution

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
                Loop
            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
    Do
        NbrDigits = NbrDigits + 1
        Dim HighLim As Long
        X = 10 ^ (NbrDigits - 1)
        HighLim = Int(10 ^ (NbrDigits) / 6)
        Dim MatchFound As Boolean
        Do
            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