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 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