﻿ Project Euler Problem 52
You are on the Home/Other Tutorials/Project Euler/Problem 52 page Share Your

# Project Euler - Problem 52

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

## 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
aDigit = aVal Mod 10: aVal = aVal \ 10
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```