FC2ブログ

Excel VBA をやってみた その11 


副題:hatena さんに挑戦・・・っていうか、もう一度やってみた・・・

Excel VBA をやってみた その3(合計値検索)」とか
再帰処理にはまる(その4 乾杯!!)」のリベンジ(?)になるか・・・返り討ちの雰囲気ですが・・・

hatena さんの記事「VBAで組み合わせ合計探索」を、自分なりにやってみたものになります。
詳細の仕様/サンプルファイルの入手は hatena さんの記事を参考にしてください。

私の考え方のベースは、再帰処理・・・があるんですが・・・・・ これじゃ遅いんですよね
でも、記述量は少なくて済むんですけどね・・・

回答していて、再帰を使わない処理を見かける事もあります。
最近勉強になったのは、「エクセルVBAにて4つの文字の全ての組み合わせを抽出したいです。」ですね・・・

ということで、再帰処理を使わない方法も考えてみたものの・・・・
結構速くなったんですけどね・・・

私のサンプルファイルは、「Excel VBA をやってみた その3(合計値検索)」のシートの中で

kEnt201.jpg

を、再帰なしでやってみたものになります。
数値が並んでいる C / F 列の右側( D / G 列)に、得たい合計値を入力すると、
数値の2行目から入力した左までのものを使って、組合せを求めます。
求めたものは組合せが無くても、新規シートに出力されます。

kEnt201_1.jpg  kEnt201_2.jpg

kEnt201_3.jpg  kEnt201_4.jpg

A1 には、求めたい値が・・・・、表示は行と列を入れ替えて・・・・
求める組合せ数に制限を付けていないので、組合せが多くなればそれなりに遅くなります。

【追記】2017/1/7
重複組み合わせ」の中でも同じことができたり・・・
 
hatena さんのサンプルファイルを入手して、
新しく標準モジュールとして追加した記述は以下になります。
Option Explicit

' CC = 0 ReCode / myPrint
' CC = 1 NotReCode / myPrint
' CC = 2 ReCode / myPrint2
' CC = 3 NotReCode / myPrint2

Const CC = 1

Dim dic As Object

Public Sub Samp1()
  Dim dicR As Object
  Dim sS As String
  Dim i As Long, j As Long
  Dim iCol As Long
  Dim v As Variant, vS As Variant
  Dim vSrc As Variant
  Dim iAryDst() As Long

  With ActiveSheet.UsedRange
    .Offset(, 4).Resize(, .Columns.Count - 4).ClearContents
  End With

  Set dicR = CreateObject("Scripting.Dictionary")
  For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
    With Cells(i, "A")
      sS = .Offset(, 1).Value
      If (Not dicR.Exists(sS)) Then
        dicR.Add sS, CreateObject("Scripting.Dictionary")
      End If
      j = dicR(sS).Count + 1
      dicR(sS)(j) = Array(.Value, i, 0)
    End With
  Next

  Set dic = CreateObject("Scripting.Dictionary")
  vS = Cells(2, "C").Value
  iCol = 5
  For Each v In dicR.Keys
    dic.Add v, CreateObject("Scripting.Dictionary")
    vSrc = mySort(dicR(v).Items)
    ReDim iAryDst(LBound(vSrc) To UBound(vSrc))
    If ((CC Mod 2) = 0) Then
      Call ReCode(v, vS, vSrc, LBound(vSrc), iAryDst, LBound(iAryDst))
    Else
      Call NotReCode(v, vS, vSrc, LBound(vSrc), iAryDst, LBound(iAryDst))
    End If
    If (dic(v).Count > 0) Then
      If ((CC \ 2) = 0) Then
        iCol = myPrint(v, iCol, vSrc, dic(v).Items)
      Else
        iCol = myPrint2(v, iCol, vSrc, dic(v).Items)
      End If
    End If
  Next
  Set dicR = Nothing
  Set dic = Nothing
End Sub

Private Function mySort(ByVal vSrc As Variant) As Variant
  Dim v As Variant
  Dim i As Long
  Dim bNG As Boolean

  bNG = True
  While (bNG)
    bNG = False
    For i = LBound(vSrc) To UBound(vSrc) - 1
      If (vSrc(i)(0) < vSrc(i + 1)(0)) Then
        v = vSrc(i)
        vSrc(i) = vSrc(i + 1)
        vSrc(i + 1) = v
        bNG = True
      End If
    Next
  Wend
  For i = UBound(vSrc) - 1 To LBound(vSrc) Step -1
    vSrc(i)(2) = vSrc(i + 1)(0) + vSrc(i + 1)(2)
  Next
  mySort = vSrc
End Function

Private Sub ReCode(vC As Variant, vNum As Variant _
        , vSrc As Variant, iSrcPos As Long _
        , iAryDst() As Long, iDstPos As Long)
  Dim i As Long, j As Long
  Dim v As Variant

  For i = iSrcPos To UBound(vSrc)
    v = vSrc(i)
    If ((v(0) + v(2)) < vNum) Then
      Exit For
    Else
      iAryDst(iDstPos) = i
      If (vNum = v(0)) Then
        j = dic(vC).Count
        dic(vC)(j) = Array(iAryDst, iDstPos)
      Else
        Call ReCode(vC, vNum - v(0), vSrc, i + 1, iAryDst, iDstPos + 1)
      End If
    End If
  Next
End Sub

Private Sub NotReCode(vC As Variant, vNum As Variant _
        , vSrc As Variant, iSrcPos As Long _
        , iAryDst() As Long, iDstPos As Long)
  Dim iPosAry() As Long, iPosMax As Long
  Dim iRdPos As Long, iPos As Long
  Dim vSum As Variant, v As Variant
  Dim i As Long

  iPosMax = UBound(vSrc)
  iRdPos = LBound(vSrc)
  iPos = iRdPos
  ReDim iPosAry(iPos To iPosMax)
  vSum = 0

  While (vSrc(iRdPos)(0) > vNum)
    iRdPos = iRdPos + 1
    If (iRdPos > iPosMax) Then Exit Sub
  Wend

  While (1)
    v = vNum - vSum
    Do
      If (iRdPos > iPosMax) Then
        If (iPos <= LBound(iPosAry)) Then Exit Sub ' ここでのみ大元 While を抜ける
        iPos = iPos - 1
        iRdPos = iPosAry(iPos) + 1
        vSum = vSum - vSrc(iRdPos - 1)(0)
        v = vNum - vSum
      End If
      Do While (iRdPos <= iPosMax)
        If ((vSrc(iRdPos)(0) + vSrc(iRdPos)(2)) < v) Then
          iRdPos = iPosMax
        ElseIf (vSrc(iRdPos)(0) <= v) Then
          Exit Do
        End If
        iRdPos = iRdPos + 1
      Loop
    Loop While (iRdPos > iPosMax)
    iPosAry(iPos) = iRdPos
    If (v = vSrc(iRdPos)(0)) Then
      i = dic(vC).Count
      dic(vC)(i) = Array(iPosAry, iPos)
    Else
      vSum = vSum + vSrc(iRdPos)(0)
      iPos = iPos + 1
    End If
    iRdPos = iRdPos + 1
  Wend
End Sub

Private Function myPrint(vC As Variant, iCol As Long _
            , vSrc As Variant, vA As Variant) As Long
  Dim i As Long, j As Long
  Dim v As Variant, vv As Variant

  j = 0
  For Each v In vA
    vv = v(0)
    For i = LBound(vv) To v(1)
      Cells(vSrc(vv(i))(1), iCol + j).Value = "○"
    Next
    j = j + 1
  Next
  myPrint = iCol + j
End Function

Private Function myPrint2(vC As Variant, iCol As Long _
            , vSrc As Variant, vA As Variant) As Long
  Dim ws As Worksheet
  Dim i As Long, j As Long
  Dim v As Variant, vv As Variant

  On Error Resume Next
  Set ws = Worksheets(vC)
  If (Err <> 0) Then
    Set ws = Worksheets.Add(After:=ActiveSheet)
    ws.Name = vC
  End If
  With ws
    .Cells.Clear

    For Each v In vSrc
      .Cells(v(1), "A").Value = v(0)
    Next
    j = 0
    For Each v In vA
      vv = v(0)
      j = j + 1
      For i = LBound(vv) To v(1)
        .Cells(vSrc(vv(i))(1), "A").Offset(, j).Value = "○"
      Next
    Next
    With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
      .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
      With .Offset(, 1).Resize(, j)
        .HorizontalAlignment = xlCenter
        .EntireColumn.AutoFit
      End With
    End With
  End With
  myPrint2 = iCol + j
End Function

 
徐々に説明していきますが、おおざっぱに
・Dictionary 2段構成で元データを管理
1段目キー:B列の名称  2段目のキー:シーケンシャルに・・・・
2段目のキーは使わずに、値だけを利用
その値の内容は、Array( A列の値、記述行、後で利用する積算用 ) の配列
・データの取り込みが終わったら組合せの処理
読み込んだ B列の名称ごとに、値を降順で並び替えた後
 関数 ReCode :再帰を利用したもの
 関数 NotReCode :ループ処理
・組合せがあったら
 関数 myPrint :データがあったシートに単なる上書き
 関数 myPrint2 :読み込んだ B列の名称ごとにシート作成&組合せ転記

ReCode / NotReCode および myPrint / myPrint2 の引数は同じで、
中身の記述だけを変更しています。
(使っていない引数とか出てきていますけど)


では、詳細に・・・

以下部分で、Dictionary 2段構成でデータを取り込んでいきます
  Set dicR = CreateObject("Scripting.Dictionary")
  For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
    With Cells(i, "A")
      sS = .Offset(, 1).Value
      If (Not dicR.Exists(sS)) Then
        dicR.Add sS, CreateObject("Scripting.Dictionary")
      End If
      j = dicR(sS).Count + 1
      dicR(sS)(j) = Array(.Value, i, 0)
    End With
  Next
2段目のキーは重複しない連番を使って、配列のデータを値に設定
      j = dicR(sS).Count + 1
      dicR(sS)(j) = Array(.Value, i, 0)

以下では、求めたい合計値を vS に、
結果書き出し列 iCol を、E (=5)列に、
結果を、これまた 2段構成の dic に・・・・
読み込んだ名称ごとに、値を配列化して、降順にソートして、
求めたい組合せがあったら、結果出力して・・・
  Set dic = CreateObject("Scripting.Dictionary")
  vS = Cells(2, "C").Value
  iCol = 5
  For Each v In dicR.Keys
    dic.Add v, CreateObject("Scripting.Dictionary")
    vSrc = mySort(dicR(v).Items)
    ReDim iAryDst(LBound(vSrc) To UBound(vSrc))
    If ((CC Mod 2) = 0) Then
      Call ReCode(v, vS, vSrc, LBound(vSrc), iAryDst, LBound(iAryDst))
    Else
      Call NotReCode(v, vS, vSrc, LBound(vSrc), iAryDst, LBound(iAryDst))
    End If
    If (dic(v).Count > 0) Then
      If ((CC \ 2) = 0) Then
        iCol = myPrint(v, iCol, vSrc, dic(v).Items)
      Else
        iCol = myPrint2(v, iCol, vSrc, dic(v).Items)
      End If
    End If
  Next
とまぁ・・・こんな感じになりますが、
組合せを得る処理・書き出す処理の指定は、先頭に記述していた以下で指定
' CC = 0 ReCode / myPrint
' CC = 1 NotReCode / myPrint
' CC = 2 ReCode / myPrint2
' CC = 3 NotReCode / myPrint2

Const CC = 1

ソートの処理は、バブル(?)ソートで降順に・・・
Private Function mySort(ByVal vSrc As Variant) As Variant
  Dim v As Variant
  Dim i As Long
  Dim bNG As Boolean

  bNG = True
  While (bNG)
    bNG = False
    For i = LBound(vSrc) To UBound(vSrc) - 1
      If (vSrc(i)(0) < vSrc(i + 1)(0)) Then
        v = vSrc(i)
        vSrc(i) = vSrc(i + 1)
        vSrc(i + 1) = v
        bNG = True
      End If
    Next
  Wend
  For i = UBound(vSrc) - 1 To LBound(vSrc) Step -1
    vSrc(i)(2) = vSrc(i + 1)(0) + vSrc(i + 1)(2)
  Next
  mySort = vSrc
End Function
ソート後、積算用部分を生成
  For i = UBound(vSrc) - 1 To LBound(vSrc) Step -1
    vSrc(i)(2) = vSrc(i + 1)(0) + vSrc(i + 1)(2)
  Next
例えば
vSrc(0): Array( 90, xxx, 0 )
vSrc(1): Array( 40, xxx, 0 )
vSrc(2): Array( 20, xxx, 0 )
↓なら
vSrc(0): Array( 90, xxx, 60 )
vSrc(1): Array( 40, xxx, 20 )
vSrc(2): Array( 20, xxx, 0 )

この積算用を利用することで、ループ回数を減らす事が出来るのかな???・・・

さて、心臓部分になる組合せを求める処理になりますが、
再帰でのものは
Private Sub ReCode(vC As Variant, vNum As Variant _
        , vSrc As Variant, iSrcPos As Long _
        , iAryDst() As Long, iDstPos As Long)
  Dim i As Long, j As Long
  Dim v As Variant

  For i = iSrcPos To UBound(vSrc)
    v = vSrc(i)
    If ((v(0) + v(2)) < vNum) Then
      Exit For
    Else
      iAryDst(iDstPos) = i
      If (vNum = v(0)) Then
        j = dic(vC).Count
        dic(vC)(j) = Array(iAryDst, iDstPos)
      Else
        Call ReCode(vC, vNum - v(0), vSrc, i + 1, iAryDst, iDstPos + 1)
      End If
    End If
  Next
End Sub
としました。
求めたい数値が引数の vNum
どの配列を参照して・・・・ vSrc
私は vSrc の、どの位置から処理すれば良いの・・・・ iSrcPos
候補が見つかったらどこに入れとけば良いの・・・ iAryDst
この iAryDst は配列で、組合せで利用した vSrc 内の位置情報のみを格納します。
どの場所に(どこまで iAryDst 使っている?)・・・ iDstPos
なので、結果として書き出す際には、vSrc、iAryDst、iDstPos の3つが必要になります。

求めたい値がなかったら戻ります
    If ((v(0) + v(2)) < vNum) Then
      Exit For
ここで、積算用の値が生きてきますね・・・
つまり、配列として以降に何個値があるかわからないけど、全部足しても求めたい値以下なら・・・・
結構、ループ回数を削減できるのかな・・・
求めたい値が、一致するものがあったら Dictionary に登録
      iAryDst(iDstPos) = i
      If (vNum = v(0)) Then
        j = dic(vC).Count
        dic(vC)(j) = Array(iAryDst, iDstPos)
値としては、Array(iAryDst, iDstPos) として、位置情報の配列と、どこまで使っているか・・・を
値が一致していなかったら、再帰呼び出しで
求めたい値を更新して、各位置ポインタを更新して・・・・
      Else
        Call ReCode(vC, vNum - v(0), vSrc, i + 1, iAryDst, iDstPos + 1)

【追記】8.27
元々のデータを「降順&積算値導入」とした事で
Excel VBA をやってみた その3(合計値検索)」とか
再帰処理にはまる(その4 乾杯!!)」でやっていた次候補云々の処理がなくなった分
この記述だけでも、それなりに速くなったような気も・・・ 気のせいだった・・・


再帰処理をしない処理として以下を記述してみました
Private Sub NotReCode(vC As Variant, vNum As Variant _
        , vSrc As Variant, iSrcPos As Long _
        , iAryDst() As Long, iDstPos As Long)
  Dim iPosAry() As Long, iPosMax As Long
  Dim iRdPos As Long, iPos As Long
  Dim vSum As Variant, v As Variant
  Dim i As Long

  iPosMax = UBound(vSrc)
  iRdPos = LBound(vSrc)
  iPos = iRdPos
  ReDim iPosAry(iPos To iPosMax)
  vSum = 0

  While (vSrc(iRdPos)(0) > vNum)
    iRdPos = iRdPos + 1
    If (iRdPos > iPosMax) Then Exit Sub
  Wend

  While (1)
    v = vNum - vSum
    Do
      If (iRdPos > iPosMax) Then
        If (iPos <= LBound(iPosAry)) Then Exit Sub ' ここでのみ大元 While を抜ける
        iPos = iPos - 1
        iRdPos = iPosAry(iPos) + 1
        vSum = vSum - vSrc(iRdPos - 1)(0)
        v = vNum - vSum
      End If
      Do While (iRdPos <= iPosMax)
        If ((vSrc(iRdPos)(0) + vSrc(iRdPos)(2)) < v) Then
          iRdPos = iPosMax
        ElseIf (vSrc(iRdPos)(0) <= v) Then
          Exit Do
        End If
        iRdPos = iRdPos + 1
      Loop
    Loop While (iRdPos > iPosMax)
    iPosAry(iPos) = iRdPos
    If (v = vSrc(iRdPos)(0)) Then
      i = dic(vC).Count
      dic(vC)(i) = Array(iPosAry, iPos)
    Else
      vSum = vSum + vSrc(iRdPos)(0)
      iPos = iPos + 1
    End If
    iRdPos = iRdPos + 1
  Wend
End Sub

 
  iPosMax = UBound(vSrc)
  iRdPos = LBound(vSrc)
  iPos = iRdPos
  ReDim iPosAry(iPos To iPosMax)
  vSum = 0
ここでは、動く環境を設定
iPosMax : 処理する配列の最後の位置
iRdPos : 処理を開始する位置
iPos : 位置情報を格納する位置
iPosAry : 位置情報を格納する配列(元々の vSrc 配列数分あれば十分)
vSum : 処理の過程で組合せ候補の値を加算したもの

vNum : 関数の引数で、求めたい値

※ 関数の引数の中で使わないもの iSrcPos / iAryDst / iDstPos の3つ

  While (vSrc(iRdPos)(0) > vNum)
    iRdPos = iRdPos + 1
    If (iRdPos > iPosMax) Then Exit Sub
  Wend
ここでは、求めたい値以上の値が配列内にあったら、開始位置を更新
※ これは、配列内の値を降順にしていたので、有効なループ回数削減になる?

無限ループ内で処理を進めます
  While (1)

まず、今回の処理で求めたい値を
    v = vNum - vSum
で求めておいてから候補の選択処理を行います。
iRdPos / iPos の基本的な動きは以下の様になります。

kEnt201_5.jpg

実際の処理としては、
候補がない場合、iRdPos を iPosMax 以上に設定します。
で、iPosAry 内の情報で iRdPos を再設定しようとしますが、
この時、iPos が配列先頭から移動していない場合、一連の処理を終了します。
この方法にしたのは、iRdPos への再設定箇所を一箇所にまとめたかったので・・・
    Do
      If (iRdPos > iPosMax) Then
        If (iPos <= LBound(iPosAry)) Then Exit Sub ' ここでのみ大元 While を抜ける
        iPos = iPos - 1
        iRdPos = iPosAry(iPos) + 1
        vSum = vSum - vSrc(iRdPos - 1)(0)
        v = vNum - vSum
      End If
      Do While (iRdPos <= iPosMax)
        If ((vSrc(iRdPos)(0) + vSrc(iRdPos)(2)) < v) Then
          iRdPos = iPosMax
        ElseIf (vSrc(iRdPos)(0) <= v) Then
          Exit Do
        End If
        iRdPos = iRdPos + 1
      Loop
    Loop While (iRdPos > iPosMax)
この所は、iRdPos 再設定後に候補がない時もあるのか・・・
色々考えてみて、Do While ~ Loop / Do ~ Loop While のチョッとややこしい記述になってます。
※ 私は、あまり Until 記述はしません・・・・ って、While の方が考えやすいので・・・

ループを抜けた後
    iPosAry(iPos) = iRdPos
    If (v = vSrc(iRdPos)(0)) Then
      i = dic(vC).Count
      dic(vC)(i) = Array(iPosAry, iPos)
    Else
      vSum = vSum + vSrc(iRdPos)(0)
      iPos = iPos + 1
    End If
    iRdPos = iRdPos + 1
と処理しています。
値が一致した時に、iRdPos のみ進めているのは、vSrc 内に同じ数値が入っているかも・・・
※ 値を扱う変数は Variant にしていました。
小数点含みの値も扱えるように・・・とかではなくて・・・ Long で扱えない場合どうする・・・
がメインでしたけど、それ用の確認はしていないし・・・・どう動くんですかね??
小数点含みの場合もある程度動けるかもしれない・・・ まともじゃない方が大ですかね・・・
vSum = vSum + xxx とか vSum = vSum - yyy とか結構してますね・・・
計算誤差がどんどんたまっていく方向にしかありませんよね・・・
0.5 単位、0.25 単位とか誤差がたまらない分には大丈夫???・・・

で、組合せを求める処理が終わったので最後にシートへの結果転記
同一シートへの出力は以下の様な感じで
Private Function myPrint(vC As Variant, iCol As Long _
            , vSrc As Variant, vA As Variant) As Long
  Dim i As Long, j As Long
  Dim v As Variant, vv As Variant

  j = 0
  For Each v In vA
    vv = v(0)
    For i = LBound(vv) To v(1)
      Cells(vSrc(vv(i))(1), iCol + j).Value = "○"
    Next
    j = j + 1
  Next
  myPrint = iCol + j
End Function

そして、結果を別シートに作ってみましょうか・・・
その時のシート名には、元々B列に記述あった名称を使いましょう
Private Function myPrint2(vC As Variant, iCol As Long _
            , vSrc As Variant, vA As Variant) As Long
  Dim ws As Worksheet
  Dim i As Long, j As Long
  Dim v As Variant, vv As Variant

  On Error Resume Next
  Set ws = Worksheets(vC)
  If (Err <> 0) Then
    Set ws = Worksheets.Add(After:=ActiveSheet)
    ws.Name = vC
  End If
  With ws
    .Cells.Clear

    For Each v In vSrc
      .Cells(v(1), "A").Value = v(0)
    Next
    j = 0
    For Each v In vA
      vv = v(0)
      j = j + 1
      For i = LBound(vv) To v(1)
        .Cells(vSrc(vv(i))(1), "A").Offset(, j).Value = "○"
      Next
    Next
    With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
      .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
      With .Offset(, 1).Resize(, j)
        .HorizontalAlignment = xlCenter
        .EntireColumn.AutoFit
      End With
    End With
  End With
  myPrint2 = iCol + j
End Function

A列には、元々B列の名称に絞った値のみを表示して・・・
B列から組合せの結果を・・・・

※※ この時、組合せ数が使用できる列数を超えたら・・・処理は入れてません・・・
求める組合せ数の上限を設けていないので、エラーになったらなったらで・・・


とまぁ、hatena さんサンプルを使った処理を記述してきましたが、
以降は、「Excel VBA をやってみた その3(合計値検索)」のシート「パターン」用に修正したもの・・・
再帰処理しないものになるので、再帰を使ったものは過去記事を触ってみてください。

シートは「パターン」のみです。

kEnt201.jpg

操作は、数値が並んでいる C / F 列の右側( D / G 列)に、得たい合計値を入力すると、
数値の2行目から入力した左までのものを使って、組合せを求めます。
求めたものは組合せが無くても、新規シートに出力されます。

kEnt201_2.jpg  kEnt201_4.jpg

A1 には、求めたい値が・・・・、表示は行と列を入れ替えて・・・・
求める組合せ数に制限を付けていないので、組合せが多くなればそれなりに遅くなります。

シート「パターン」の Worksheet_Change に以下を記述します
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim dic As Object
  Dim rng As Range, r As Range
  Dim i As Long, j As Long

  With Target
    If (.Count <> 1) Then Exit Sub
    If (.Row = 1) Then Exit Sub
    Select Case .Column
      Case 4, 7
      Case Else: Exit Sub
    End Select
    If (.Value = "") Then Exit Sub
    If (Not IsNumeric(.Value)) Then Exit Sub
    If (.Offset(, -1).Value = "") Then Exit Sub

    Set dic = CreateObject("Scripting.Dictionary")
    i = 2
    For Each r In Range(Cells(2, .Offset(, -1).Column), .Offset(, -1))
      j = dic.Count
      dic(j) = Array(r.Value, i, 0)
      i = i + 1
    Next
    Call Samp2(dic, .Value)
    Set dic = Nothing
  End With
End Sub

 
で、標準モジュールには以下を記述しています

Dim dic As Object

Public Sub Samp2(dicR As Object, vS As Variant)
  Dim vSrc As Variant

  Set dic = CreateObject("Scripting.Dictionary")
  vSrc = mySort(dicR.Items)
  Call NotReCode(vS, vSrc)
  Call myPrint2(vS, vSrc, dic.Items)
  Set dic = Nothing
End Sub

Private Function mySort(ByVal vSrc As Variant) As Variant
  Dim v As Variant
  Dim i As Long
  Dim bNG As Boolean

  bNG = True
  While (bNG)
    bNG = False
    For i = LBound(vSrc) To UBound(vSrc) - 1
      If (vSrc(i)(0) < vSrc(i + 1)(0)) Then
        v = vSrc(i)
        vSrc(i) = vSrc(i + 1)
        vSrc(i + 1) = v
        bNG = True
      End If
    Next
  Wend
  For i = UBound(vSrc) - 1 To LBound(vSrc) Step -1
    vSrc(i)(2) = vSrc(i + 1)(0) + vSrc(i + 1)(2)
  Next
  mySort = vSrc
End Function

Private Sub NotReCode(vNum As Variant, vSrc As Variant)
  Dim iPosAry() As Long, iPosMax As Long
  Dim iRdPos As Long, iPos As Long
  Dim vSum As Variant, v As Variant
  Dim i As Long

  iPosMax = UBound(vSrc)
  iRdPos = LBound(vSrc)
  iPos = iRdPos
  ReDim iPosAry(iPos To iPosMax)
  vSum = 0

  While (vSrc(iRdPos)(0) > vNum)
    iRdPos = iRdPos + 1
    If (iRdPos > iPosMax) Then Exit Sub
  Wend

  While (1)
    v = vNum - vSum
    Do
      If (iRdPos > iPosMax) Then
        If (iPos <= LBound(iPosAry)) Then Exit Sub ' ここでのみ大元 While を抜ける
        iPos = iPos - 1
        iRdPos = iPosAry(iPos) + 1
        vSum = vSum - vSrc(iRdPos - 1)(0)
        v = vNum - vSum
      End If
      Do While (iRdPos <= iPosMax)
        If ((vSrc(iRdPos)(0) + vSrc(iRdPos)(2)) < v) Then
          iRdPos = iPosMax
        ElseIf (vSrc(iRdPos)(0) <= v) Then
          Exit Do
        End If
        iRdPos = iRdPos + 1
      Loop
    Loop While (iRdPos > iPosMax)
    iPosAry(iPos) = iRdPos
    If (v = vSrc(iRdPos)(0)) Then
      i = dic.Count
      dic(i) = Array(iPosAry, iPos)
    Else
      vSum = vSum + vSrc(iRdPos)(0)
      iPos = iPos + 1
    End If
    iRdPos = iRdPos + 1
  Wend
End Sub

Private Sub myPrint2(vNum As Variant, vSrc As Variant, vA As Variant)
  Dim i As Long, j As Long
  Dim v As Variant, vv As Variant

  On Error Resume Next
  With Worksheets.Add(After:=ActiveSheet)
    .Cells(1, "A").Value = vNum
    For Each v In vSrc
      .Cells(1, v(1)).Value = v(0)
    Next
    j = 1
    For Each v In vA
      vv = v(0)
      .Cells(j + 1, "A") = j
      For i = LBound(vv) To v(1)
        .Cells(1, vSrc(vv(i))(1)).Offset(j).Value = "○"
      Next
      j = j + 1
    Next
    With .UsedRange
      .Rows(1).Interior.ColorIndex = 20
      .Cells(1).Interior.ColorIndex = 24
      For i = 3 To .Rows.Count Step 2
        .Rows(i).Interior.ColorIndex = 36
      Next
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
      .EntireColumn.AutoFit
    End With
  End With
End Sub

 
処理的には、大きな変更はないですよね・・・
ただ、上記で確認していて不満な点が・・・・
組合せ数が多くなると、新規シートが表示されてから最終形になるまで結構な時間が掛かるよね・・・
組合せを求める部分はソコソコ速くなったのに・・・ もうチョッと速くできないかな・・・

まずは、シートを作って・・・・部分に ScreenUpdating を適用しましょうか
また、
マクロでファイルを読み込み、重複行を削除したい。
http://oshiete.goo.ne.jp/qa/8691314.html
でも勉強になりましたが、セルへのアクセス回数を減らせば・・・
この2点を適用してみますか・・・・・(この部分はサンプルファイルにはありません)
Private Sub myPrint2(vNum As Variant, vSrc As Variant, vA As Variant)
  Dim iRowMax As Long
  Dim i As Long, j As Long
  Dim v As Variant, vv As Variant
  Dim vData As Variant

  On Error Resume Next
  iRowMax = UBound(vA) - LBound(vA) + 2
  If (iRowMax > Rows.Count) Then iRowMax = Rows.Count
  ReDim vData(1 To iRowMax, 1 To UBound(vSrc) - LBound(vSrc) + 2)
  vData(1, 1) = vNum
  For Each v In vSrc
    vData(1, v(1)) = v(0)
  Next
  j = 1
  For Each v In vA
    vv = v(0)
    vData(j + 1, 1) = j
    For i = LBound(vv) To v(1)
      vData(j + 1, vSrc(vv(i))(1)) = "○"
    Next
    j = j + 1
    If (j > iRowMax) Then Exit For
  Next
  Application.ScreenUpdating = False
  With Worksheets.Add(After:=ActiveSheet)
    With .Cells(1, 1).Resize(iRowMax, UBound(vData, 2))
      .Value = vData
      .Rows(1).Interior.ColorIndex = 20
      .Cells(1).Interior.ColorIndex = 24
      For i = 3 To .Rows.Count Step 2
        .Rows(i).Interior.ColorIndex = 36
      Next
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
      .EntireColumn.AutoFit
    End With
  End With
  Application.ScreenUpdating = True
End Sub

※ 実際にサンプルファイルで確認する場合、
上記の記述に書き換えた時との速さの違いは、実際に体感してみてください。

なお、前述2点以外にも修正してました
  iRowMax = UBound(vA) - LBound(vA) + 2
  If (iRowMax > Rows.Count) Then iRowMax = Rows.Count
この部分、サンプルファイルは 2007 で作った xls ファイル(互換)なので、
扱える最終行は、65536 ・・・・
この上限を超える組合せパターンがすぐに出現したので・・・一応表示できる所までということに
例えば、 G31 に 5555 とか入れると、組合せ数は、111109 になるとか・・・
全部を表示してみたい時には、xlsm で保存後、開き直して同じ事をやれば・・・・

サンプルは以下
 バージョン 2000 でも
 ファイル kEnt201.zip
 サイズ 11,398
※ ファイルは zip 形式
※ 2007 で作成した Excel ファイル(互換:xls)



【追記】8.27
最後に記述していた表示の高速版で、以下修正すると値が大きい順に表示されます

kEnt201_6.jpg

※ 今までの表示だと、同じ組み合わせが他にもあるんじゃ・・・ 一見してわからなかったと思います
 この表示を見ると、同じ組み合わせのものはない事がわかると思います。
 また、どういった処理順で求めていたのかがわかりやすいかも・・・
Private Sub myPrint2(vNum As Variant, vSrc As Variant, vA As Variant)
  Dim iRowMax As Long
  Dim i As Long, j As Long
  Dim v As Variant, vv As Variant
  Dim vData As Variant

  On Error Resume Next
  iRowMax = UBound(vA) - LBound(vA) + 2
  If (iRowMax > Rows.Count) Then iRowMax = Rows.Count
  ReDim vData(1 To iRowMax, 1 To UBound(vSrc) - LBound(vSrc) + 2)
  vData(1, 1) = vNum
  i = 2
  For Each v In vSrc
    vData(1, i) = v(0)
    i = i + 1
  Next
  j = 1
  For Each v In vA
    vv = v(0)
    vData(j + 1, 1) = j
    For i = LBound(vv) To v(1)
      vData(j + 1, vv(i) - LBound(vSrc) + 2) = "○"
    Next
    j = j + 1
    If (j > iRowMax) Then Exit For
  Next
  Application.ScreenUpdating = False
  With Worksheets.Add(After:=ActiveSheet)
    With .Cells(1, 1).Resize(iRowMax, UBound(vData, 2))
      .Value = vData
      .Rows(1).Interior.ColorIndex = 20
      .Cells(1).Interior.ColorIndex = 24
      For i = 3 To .Rows.Count Step 2
        .Rows(i).Interior.ColorIndex = 36
      Next
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
      .EntireColumn.AutoFit
    End With
  End With
  Application.ScreenUpdating = True
End Sub
関連記事

2014/08/26

Category: やってみる

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △