| |
一応作りましたが、ものすごく遅いです・・・
Private strArray() As String
Private colCombins As Collection
Private lngPatterns() As Long
Private lngLength As Long
Private lngDiv As Long
Sub CallGetCombin()
Call PS_GetCombin("ABCDEFGH", 4)
End Sub
Public Sub PS_GetCombin(ByRef strTarget As String, _
ByVal lngDivide As Long)
Dim vntCombin As Variant
Dim strPatterns() As String
Dim strCombin() As String
Dim lngCount As Long
Dim lngDefault As Long
Dim i As Long, j As Long, t As Currency
t = Timer
lngLength = Len(strTarget) - 1&
lngDiv = lngDivide - 1
If lngLength < lngDiv Or lngLength > 30& Then
Debug.Print "Error"
Exit Sub
End If
lngDefault = 2& ^ (lngLength + 1&) - 1&
ReDim lngPatterns(lngDiv)
ReDim strPatterns(lngDiv)
Set colCombins = New Collection
'文字列を1文字ごとに配列に格納
Call MS_DevideStrings(strTarget)
'組み合わせ取得
Call MS_GetPattern(lngDefault, 0&, 0&, 0&)
lngCount = colCombins.Count
ReDim strCombin(1& To lngCount, 1& To 1&)
For Each vntCombin In colCombins
j = j + 1
For i = 0 To lngDiv
strPatterns(i) = MF_strConvString(vntCombin(i))
Next i
strCombin(j, 1) = Join(strPatterns, ":")
Next vntCombin
Cells(1&, 1&).Resize(lngCount) = strCombin
Debug.Print Timer - t
End Sub
'文字列を1文字ごとに配列に格納
Private Sub MS_DevideStrings(ByRef strTarget As String)
Dim i As Long
ReDim strArray(0 To lngLength)
For i = 0 To lngLength
strArray(lngLength - i) = Mid$(strTarget, i + 1, 1)
Next i
End Sub
'組み合わせ作成
Private Sub MS_GetPattern(ByVal lngBase As Long, _
ByVal lngPattern As Long, _
ByVal lngBitCount As Long, _
ByVal lngDivCount As Long)
Dim lngBit As Long
Dim i As Long, j As Long
'これ以上分割できない場合
If lngDiv - lngDivCount = 0& Then
lngPatterns(lngDivCount) = lngBase
Call MS_StorePattern
Exit Sub
End If
For i = lngLength To 0& Step -1
lngBit = 2& ^ i
'有効なbitの場合
If lngBase And lngBit Then
lngPatterns(lngDivCount) = lngPattern Or lngBit
'次の分割に進む
Call MS_GetPattern(lngBase - lngBit, 0&, _
lngBitCount + 1&, lngDivCount + 1&)
'bitに余裕がある場合
If lngLength - lngBitCount - lngDiv + lngDivCount > 1& Then
'bitを加算
Call MS_GetPattern(lngBase - lngBit, _
lngPatterns(lngDivCount), lngBitCount + 1&, _
lngDivCount)
End If
End If
Next i
End Sub
'降順Bubble Sort
Private Sub MS_DownBubbleSort(ByRef lngArray() As Long)
Dim lngBuf As Long
Dim i As Long, j As Long
Do While j < lngDiv
i = j + 1
Do While i < lngDiv + 1
If lngArray(j) < lngArray(i) Then
lngBuf = lngArray(j)
lngArray(j) = lngArray(i)
lngArray(i) = lngBuf
End If
i = i + 1
Loop
j = j + 1
Loop
End Sub
'重複をチェックして重複していなければCollectionに格納
Private Sub MS_StorePattern()
Dim strPrefix As String
Dim lngCurrent() As Long
Dim lngBuf() As Long
Dim lngFlg As Long
Dim blnFlg As Boolean
Dim i As Long, j As Long, k As Long
ReDim lngCurrent(lngDiv)
For j = 0 To lngDiv
lngCurrent(j) = lngPatterns(j)
Next j
Call MS_DownBubbleSort(lngCurrent)
strPrefix = lngCurrent(0) & "@"
If colCombins.Count <> 0 Then
Do
On Error Resume Next
lngBuf = colCombins(strPrefix & i)
If Err Then Exit Do
On Error GoTo 0
For j = 0 To lngDiv
If lngBuf(j) = lngCurrent(j) Then
lngFlg = lngFlg + 1
Else: Exit For
End If
Next j
If lngFlg = lngDiv + 1 Then blnFlg = True: Exit Do
lngFlg = 0
i = i + 1
Loop
End If
If Not blnFlg Then
Do
On Error Resume Next
colCombins.Add lngCurrent, strPrefix & i
i = i + 1
Loop While Err
End If
End Sub
'数値を組み合わせ文字列にする関数
Private Function MF_strConvString(ByVal lngTarget As Long) As String
Dim i As Long, j As Long, k As Long
Do
j = 2 ^ i
If lngTarget < j Then Exit Do
If lngTarget And j Then
MF_strConvString = strArray(i) & MF_strConvString
End If
i = i + 1
Loop
End Function
|
|
ちゃっぴ
- 04/11/19(金) 22:15 -
