1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
| Sub Пример_использования_Combinations()
'
'В данном примере указанны 5 значений и из них нужно найти все варианты из 3-х элементов
'
Dim v, w
w = Combinations("A,B,C,D,E", 3)
For Each v In w
Debug.Print v
Next
End Sub
Sub Пример_использования_Perm()
'
'Перебор всех возможных вариантов от 0 до указанного N..
'
Dim v, i&, j&
v = Perm(4) '-- В перестановках будут значаться цифры ..0, 1, 2, 3
For i = 0 To UBound(v, 1) 'Перечисления 1-го измерения
Debug.Print
For j = 0 To UBound(v, 2) 'Перечисления каждого элемента 2-го измерения
Debug.Print v(i, j);
Next
Next
End Sub
Sub Пример_использования_PermBin()
'
'Перебор всех возможных вариантов из определенного количества 0 и 1
'
Const _
Нулей = 4, _
Едениц = 6, _
Сумма = Нулей + Едениц
Dim v, i&, j&, s$, jj&
v = PermBin(Нулей, Едениц) 'Обращаемся к двоичной перестановке, и получаем массив
For i = j To UBound(v, 1) 'Перебор элементов 1-го измерения, в каждом элементе, элементы второго
s = String(Сумма, "1") 'Создаем строку длиной суммы элементов (можно любые знаки использовать)
For j = 0 To UBound(v, 2) 'Перебор элементов 2-го измерения, в каждом элементе, индекс знакоместа "0"
Mid$(s, v(i, j) + 1, 1) = "0" '? +1 В массиве самый нижний индекс = 0, в строке он = 1 (так-же можно ставить любой знак)
Next
Debug.Print s
jj = jj + 1: If jj = 10 Then Stop
Next
End Sub
Function PermBin(ByVal n0&, ByVal n1&) As Long()
'
'Двоичная перестановка
'Создает двумерный массив, в каждом индексе которого, комбинация из адресов пустых ячеек тоеть нулей
'Где наименьшая позиция =0 а наибольшая это сумма (n0+n1)-1
'Арг: n0 - Количество нулей // n1 - Количество едениц
'
Dim sum&, ind&, i&, j&, max&, ls&()
sum = n0 + n1: max = 1
For i = n0 + 1 To sum
max = max * i / (i - n0)
Next
ReDim ls&(max - 1, n0 - 1), p&(1 To n0), mx&(1 To n0)
For i = 1 To n0: p(i) = i - 1: mx(i) = (sum - Abs(i - n0)) - 1: Next
Do: DoEvents
For i = 0 To n0 - 1
ls(ind, i) = p(i + 1)
Next
ind = ind + 1
For i = n0 To 1 Step -1
If p(i) < mx(i) Then
p(i) = p(i) + 1
If i < n0 Then For j = i To n0 - 1: p(j + 1) = p(j) + 1: Next
Exit For
End If
Next
Loop While i > 0
PermBin = ls
End Function
Function Perm(ByVal Count&)
'
'Индексная перестановка
'Создает двумерный массив, в каждом индексе которого, комбинация из перестановок значений
'изначально указанных по возрастанию. Где наименьший=0 а наибольший = Count-1
'Арг: Count - Количество значений
'
Dim i&, j&, f&, t&
Static a&(), q&(), b As Boolean
If Not b Then
ReDim q(1 To Count): b = True: t = 1
For i = 1 To Count: q(i) = i - 1: t = t * i: Next
ReDim a(t - 1, Count - 1) As Long
Do: DoEvents: If bCancel Then b = False: Exit Function
For i = 0 To Count - 1: a(j, i) = q(i + 1): Next: j = j + 1
Loop While Perm(Count)
Perm = a: b = False: Exit Function
End If
For j = Count - 1 To 1 Step -1
If q(j) < q(j + 1) Then Exit For
Next
If j Then
For i = Count To j + 1 Step -1
If q(j) < q(i) Then f = q(j): q(j) = q(i): q(i) = f: Exit For
Next
Perm = j
End If
t = Count: For i = j + 1 To (Count + j) \ 2: f = q(i): q(i) = q(t): q(t) = f: t = t - 1: Next
End Function
Function Combinations(ByVal Text$, Optional ByVal Count&, Optional ByVal Delemiter$ = ",", Optional ByVal ProgBarObject As Object) As String()
'
'Создает список из вариантов слов (букв или цифр) которые указаны в аргументе Text через разделитель
'Арг:Text - текст с разделителями // Count - Число возможных элементов // Delemiter = Разделитель
'
Dim i&, j&, ii&, jj&, s$, sb$, ch$, uv&, uw&, cur&, b As Boolean
Dim q$(), u&, a$(), aa$(), result$()
Dim v, w
b = Not ProgBarObject Is Nothing
If Text <> "" Then
ch = Chr(0)
q = Split(Text, Delemiter): u = UBound(q)
If ((Count - 1) > u) Or (Count = 0) Then Count = u + 1
v = PermBin(Count, u - Count + 1)
w = Perm(Count)
If bCancel Then Exit Function
uv = UBound(v): uw = UBound(w)
ReDim a(Count - 1): aa = a
If b Then ProgBarObject.max = (uv + 1) * (uw + 1)
For i = 0 To uv
For ii = 0 To Count - 1
a(ii) = q(v(i, ii))
Next
For j = 0 To uw
For jj = 0 To Count - 1
aa(jj) = a(w(j, jj))
Next
s = ch & Join(aa, Delemiter)
If InStr(sb, s) = 0 Then
sb = sb & s
DoEvents: If bCancel Then Exit Function
If b Then ProgBarObject.Value = cur: cur = cur + 1
End If
Next
Next
result = Split(Mid$(sb, 2), ch)
qSortS result
Combinations = result
If b Then ProgBarObject.max = cur
End If
End Function
Sub qSortS(a$(), Optional ByVal lb& = -1, Optional ByVal ub&)
'
'Быстрая сортировка текстового списка
'
Dim i&, j&, s$, w$
If lb < 0 Then lb = LBound(a): ub = UBound(a)
i = lb: j = ub: s = a((i + j) \ 2)
Do Until i > j: Do While a(i) < s: i = i + 1: Loop: Do While a(j) > s: j = j - 1: Loop
If (i <= j) Then w = a(i): a(i) = a(j): a(j) = w: i = i + 1: j = j - 1
Loop
If lb < j Then qSortS a, lb, j
If i < ub Then qSortS a, i, ub
End Sub |
