| |
こんにちは。
多分あってると思いますが検証してないです。
Sub test()
Dim n As Integer
Dim m As Integer
Dim s As Integer
Dim d As Long
Dim rn As Long
Dim lcheck As Long
Dim quotient As Long
Dim lastrow As Long
Dim check As Long
Dim flag As Boolean
With WorksheetFunction
n = Val(InputBox("n個のアルファベットを"))
m = Val(InputBox("m個のグループに分ける"))
rn = .Power(m, n - m) * .Fact(m) '考慮する組み合わせ数
Dim myarray() As Variant
ReDim Preserve myarray(1 To rn, 1 To n)
Application.ScreenUpdating = False
Cells.Clear
For i = 1 To n '組み合わせ作成
s = 0
count = 0
If i < m Then
For j = 1 To rn
lcheck = rn \ .Fact(i)
If count < lcheck Then
myarray(j, i) = s
Else
If s < i - 1 Then
s = s + 1
Else
s = 0
End If
count = 0
End If
count = count + 1
Next
Else
For j = 1 To rn
lcheck = .Power(m, n - i)
If count < lcheck Then
myarray(j, i) = s
Else
If s < m - 1 Then
s = s + 1
Else
s = 0
End If
myarray(j, i) = s
count = 0
End If
count = count + 1
Next
End If
Next
d = 0 '要素数0のグループがない組み合わせのみ取り出す
For j = 1 To rn
flag = True
For k = 1 To m - 1
count = 0
For i = 1 To n
If myarray(j, i) = k Then count = count + 1
Next
If count = 0 Then flag = False
Next
If flag = True Then
For i = 1 To n
Cells(j, i).Offset(-d, 0).Value = myarray(j, i)
Next
Else
d = d + 1
End If
Next
For i = 1 To rn - d 'ダブリチェック用の数字を割り当てる
check = 0
For j = 1 To n
s = Cells(i, j).Value
If s <> 0 Then
check = check + .Power(2, n - j) * _
.Power(m, .CountIf(Rows(i), s) - 1)
End If
Next
Cells(i, n + 1).Value = check
Next
For i = rn - d To 1 Step -1 'ダブリ削除
If .CountIf(Columns(n + 1), Cells(i, n + 1).Value) > 1 Then
Rows(i).Delete xlShiftUp
End If
Next
lastrow = Range("A65536").End(xlUp).Row '結果
For i = 1 To lastrow
For j = 1 To n
Cells(i, n + 3).Offset(0, Cells(i, j).Value).Value = _
Cells(i, n + 3).Offset(0, Cells(i, j).Value).Value + Chr(64 + j)
Next
Next
Application.ScreenUpdating = True
End With
End Sub
|
|
hamar
- 04/11/19(金) 18:39 -
