Sort your list of numbers: 1 2 2 3 3 4
122 123 124 133 134
223 224 233 234
334
I only get ten combinations.
Sort your list of numbers: 1 2 2 3 3 4
122 123 124 133 134
223 224 233 234
334
I only get ten combinations.
Option Base 1
Sub start()
Dim list() As Integer
ReDim list(2)
list(1) = 123
list(2) = 234
combine list
End Sub
Sub combine(numbers() As Integer)
Dim r As Integer
Dim c As Integer
Dim r2 As Integer
Dim c2 As Integer
Dim pos As Integer
Dim text As String
Dim base() As String
Dim result() As String
Dim candidate As String
'-- determine length & size of numbers
number_count = UBound(numbers)
number_len = 0
For Each Number In numbers
If Len(Trim(Str(Number))) > number_len Then number_len = Len(Trim(Str(Number)))
Next Number
'-- tear numbers apart
ReDim base(number_count, number_len)
For r = 1 To number_count
For c = 1 To number_len
text = Trim(Str(numbers(r)))
base(r, c) = Mid(text, c, 1)
Next c
Next r
'-- start with first result
ReDim result(1)
result(1) = base(1, 1) & base(2, 1)
'-- combine digits
For r = 1 To number_count
For c = 1 To number_len
For r2 = 1 To number_count
For c2 = 1 To number_len
'-- do not allow numbers to combine with themselves
If r <> r2 Then
candidate = base(r, c) & base(r2, c2)
'-- check if candidate is already present
invalid = False
For Each Number In result
invalid = (candidate = Number)
If invalid Then Exit For
Next Number
'-- if candidate is valid, add to results
If Not invalid Then
ReDim Preserve result(UBound(result) + 1)
result(UBound(result)) = candidate
End If
End If
Next c2
Next r2
Next c
Next r
'-- save results to worksheet
ActiveSheet.UsedRange.Delete
For Each Item In result
ActiveSheet.Range("A" & ActiveSheet.UsedRange.Rows.Count + 2) = Item
Next Item
End Sub
Sub combine(numbers() As Integer)
Dim r As Integer
Dim c As Integer
Dim r2 As Integer
Dim c2 As Integer
Dim pos As Integer
Dim text As String
Dim base() As String
Dim result() As String
Dim candidate As String
'-- determine length & size of numbers
number_count = UBound(numbers)
number_len = 0
For Each Number In numbers
If Len(Trim(Str(Number))) > number_len Then number_len = Len(Trim(Str(Number)))
Next Number
'-- tear numbers apart
ReDim base(1)
For r = 1 To number_count
For c = 1 To number_len
text = Trim(Str(numbers(r)))
ReDim Preserve base(UBound(base) + 1)
base(UBound(base) - 1) = Mid(text, c, 1)
Next c
Next r
ReDim Preserve base(UBound(base) - 1)
ReDim result(1)
For x = 1 To UBound(base)
For y = 1 To UBound(base)
For Z = 1 To UBound(base)
If x <> y And x <> Z And y <> Z Then
candidate = base(x) & base(y) & base(Z)
'-- check if candidate is already present
invalid = False
For Each Number In result
invalid = (candidate = Number)
If invalid Then Exit For
Next Number
'-- if candidate is valid, add to results
If Not invalid Then
ReDim Preserve result(UBound(result) + 1)
result(UBound(result)) = candidate
Debug.Print candidate
End If
End If
Next Z
Next y
Next x
'-- save results to worksheet
ActiveSheet.UsedRange.Delete
For Each Item In result
ActiveSheet.Range("A" & ActiveSheet.UsedRange.Rows.Count + 2) = Item
Next Item
End Sub
Option Base 1
Sub start()
Dim list() As Integer
ReDim list(1)
list(1) = 123
'list(2) = 234
combine list
End Sub
Sub combine(numbers() As Integer)
Dim r As Integer
Dim c As Integer
Dim r2 As Integer
Dim c2 As Integer
Dim pos As Integer
Dim text As String
Dim base() As String
Dim result() As String
Dim candidate As String
'-- determine length & size of numbers
number_count = UBound(numbers)
number_len = 0
For Each Number In numbers
If Len(Trim(Str(Number))) > number_len Then number_len = Len(Trim(Str(Number)))
Next Number
'-- tear numbers apart
ReDim base(1)
For r = 1 To number_count
For c = 1 To number_len
text = Trim(Str(numbers(r)))
ReDim Preserve base(UBound(base) + 1)
base(UBound(base) - 1) = Mid(text, c, 1)
Next c
Next r
ReDim Preserve base(UBound(base) - 1)
ReDim result(1)
For x = 1 To UBound(base)
For y = 1 To UBound(base)
For Z = 1 To UBound(base)
If x <> y And x <> Z And y <> Z Then
candidate = base(x) & base(y) & base(Z)
'-- check if candidate is already present
invalid = False
For Each Number In result
invalid = (candidate = Number)
If invalid Then Exit For
Next Number
'-- if candidate is valid, add to results
If Not invalid Then
ReDim Preserve result(UBound(result) + 1)
result(UBound(result)) = candidate
Debug.Print candidate
End If
End If
Next Z
Next y
Next x
'-- save results to worksheet
ActiveSheet.UsedRange.Delete
j = 1
For Each Item In result
ActiveSheet.Range("A" & j) = Item
j = j + 1
Next Item
End Sub
[...]
If x <> y And x <> Z And y <> Z Then
If base(x) <> "" And base(y) <> "" And base(Z) <> "" Then
candidate = base(x) & base(y) & base(Z)
[...]
Dim arrElements As Variant
Dim arrResult As Variant
Dim p As Long
Sub Run_PermutRep()
'http://www.mrexcel.com/forum/showthread.php?t=436932
Dim lRow As Long
arrElements = Array("1", "2", "2", "3", "3", "4")
p = 3
ReDim arrResult(1 To (UBound(arrElements) - LBound(arrElements) + 1) ^ p, 1 To 1)
PermutRep 1, "", lRow
Application.ScreenUpdating = False
Sheets.Add
Range("A1").Resize(UBound(arrResult)) = arrResult
Application.ScreenUpdating = True
End Sub
Sub PermutRep(ByVal lInd As Long, ByVal sresult As String, ByRef lRow As Long)
'http://www.mrexcel.com/forum/showthread.php?t=436932
Dim i As Long
For i = LBound(arrElements) To UBound(arrElements)
If lInd = p Then
lRow = lRow + 1
arrResult(lRow, 1) = sresult & arrElements(i)
Else
PermutRep lInd + 1, sresult & arrElements(i), lRow
End If
Next i
End Sub
Sub combine(numbers() As Integer)
Dim valid1 As Boolean
Dim valid2 As Boolean
Dim valid3 As Boolean
'-- determine length & size of numbers
number_count = UBound(numbers)
number_len = 0
For Each Number In numbers
If Len(Trim(Str(Number))) > number_len Then number_len = Len(Trim(Str(Number)))
Next Number
'-- tear numbers apart
ReDim base(1)
For r = 1 To number_count
For c = 1 To number_len
text = Trim(Str(numbers(r)))
ReDim Preserve base(UBound(base) + 1)
base(UBound(base) - 1) = Mid(text, c, 1)
Next c
Next r
ReDim Preserve base(UBound(base) - 1)
ReDim result(1)
For candidate = 100 To 999
text = Trim(Str(candidate))
valid1 = False
valid2 = False
valid3 = False
For Each Number In base
valid1 = (Mid(text, 1, 1) = Number)
If valid1 Then Exit For
Next Number
For Each Number In base
valid2 = (Mid(text, 2, 1) = Number)
If valid2 Then Exit For
Next Number
For Each Number In base
valid3 = (Mid(text, 3, 1) = Number)
If valid3 Then Exit For
Next Number
If valid1 And valid2 And valid3 Then
ReDim Preserve result(UBound(result) + 1)
result(UBound(result)) = candidate
Debug.Print candidate
End If
Next candidate
'-- save results to worksheet
ActiveSheet.UsedRange.Delete
j = 1
For Each Item In result
ActiveSheet.Range("A" & j) = Item
j = j + 1
Next Item
End Sub
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
18 Experts available now in Live!