Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


61407 / 76738 ←次へ | 前へ→

【19951】Re:教えてください
回答  ちゃっぴ  - 04/11/19(金) 22:15 -

引用なし
パスワード
   一応作りましたが、ものすごく遅いです・・・

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
1 hits

【19670】教えてください ゆか 04/11/13(土) 16:49 質問
【19673】Re:教えてください Kein 04/11/13(土) 20:22 発言
【19675】Re:教えてください [名前なし] 04/11/13(土) 21:07 発言
【19678】Re:教えてください ichinose 04/11/14(日) 0:15 発言
【19679】Re:教えてください ちゃっぴ 04/11/14(日) 11:34 回答
【19680】Re:教えてください ちゃっぴ 04/11/14(日) 13:56 発言
【19691】ありがとうございます ゆか 04/11/15(月) 12:06 お礼
【19710】教えてください ゆか 04/11/15(月) 16:48 質問
【19946】Re:教えてください hamar 04/11/19(金) 18:39 回答
【19951】Re:教えてください ちゃっぴ 04/11/19(金) 22:15 回答
【19953】Re:教えてください ちゃっぴ 04/11/19(金) 22:21 発言
【19957】Re:教えてください ichinose 04/11/20(土) 0:29 発言
【19958】Re:教えてください ちゃっぴ 04/11/20(土) 0:33 発言
【19959】Re:教えてください 追伸 ichinose 04/11/20(土) 1:22 発言
【20041】ありがとうございました! ゆか 04/11/25(木) 11:42 お礼

61407 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free