Option Explicit
Sub ListAllCombinations()
'Updateby Extendoffice
Dim xDRg1, xDRg2, xDRg3, xDRg4, xDRg5, xDRg6, xDRg7, xDRg8, xDRg9, xDRg0 As Range
Dim xRg As Range
Dim xStr As String
Dim xFN1, xFN2, xFN3, xFN4, xFN5, xFN6, xFN7, xFN8, xFN9, xFN0 As Integer
Dim xSV1, xSV2, xSV3, xSV4, xSV5, xSV6, xSV7, xSV8, xSV9, xSV0 As String
Set xDRg1 = Range("A2:A8") 'First column data
Set xDRg2 = Range("C2:C170") 'Second column data
Set xDRg3 = Range("E2:E178") 'Third column data
Set xDRg4 = Range("G2:G35")
Set xDRg5 = Range("I2:I18")
Set xDRg6 = Range("K2:K15")
Set xDRg7 = Range("M2:M15")
Set xDRg8 = Range("O2:O10")
Set xDRg9 = Range("X2:X16")
Set xDRg0 = Range("Z2:Z3")
Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
Dim arr4 As Variant
Dim arr5 As Variant
Dim arr6 As Variant
Dim arr7 As Variant
Dim arr8 As Variant
Dim arr9 As Variant
Dim arr0 As Variant
arr1 = xDRg1
arr2 = xDRg2
arr3 = xDRg3
arr4 = xDRg4
arr5 = xDRg5
arr6 = xDRg6
arr7 = xDRg7
arr8 = xDRg8
arr9 = xDRg9
arr0 = xDRg0
xStr = "-" 'Separator
Set xRg = Range("AF2") 'Output cell
Dim iCount As Long
Dim dicOut As Object
Set dicOut = CreateObject("Scripting.Dictionary")
Dim sStr As String
Randomize
Do
xFN1 = 1 + Rnd() * (UBound(arr1, 1) - 1)
xFN2 = 1 + Rnd() * (UBound(arr2, 1) - 1)
xFN3 = 1 + Rnd() * (UBound(arr3, 1) - 1)
xFN4 = 1 + Rnd() * (UBound(arr4, 1) - 1)
xFN5 = 1 + Rnd() * (UBound(arr5, 1) - 1)
xFN6 = 1 + Rnd() * (UBound(arr6, 1) - 1)
xFN7 = 1 + Rnd() * (UBound(arr7, 1) - 1)
xFN8 = 1 + Rnd() * (UBound(arr8, 1) - 1)
xFN9 = 1 + Rnd() * (UBound(arr9, 1) - 1)
xFN0 = 1 + Rnd() * (UBound(arr0, 1) - 1)
xSV1 = arr1(xFN1, 1)
xSV2 = arr2(xFN2, 1)
xSV3 = arr3(xFN3, 1)
xSV4 = arr4(xFN4, 1)
xSV5 = arr5(xFN5, 1)
xSV6 = arr6(xFN6, 1)
xSV7 = arr7(xFN7, 1)
xSV8 = arr8(xFN8, 1)
xSV9 = arr9(xFN9, 1)
xSV0 = arr0(xFN0, 1)
' xRg.Value = xSV1 & xStr & xSV2 & xStr & xSV3 & xStr & xSV4 & xStr & xSV5 & xStr & xSV6 & xStr & xSV7 & xStr & xSV8 & xStr & xSV9 & xStr & xSV0
'Set xRg = xRg.Offset(1, 0)
iCount = iCount + 1
If iCount > 100000 Then Exit Do 'Выход по количеству всех попыток
sStr = Join(Array(xSV1, xSV2, xSV3, xSV4, xSV5, xSV6, xSV7, xSV8, xSV9, xSV0), xStr)
dicOut.Item(sStr) = 0
If dicOut.Count > 10000 Then Exit Do 'Выход по количеству удачных попыток - без повторов.
Loop
If dicOut.Count > 0 Then
xRg.Resize(dicOut.Count, 1) = Application.Transpose(dicOut.Keys())
End If
End Sub
|