code-depot for VBA

2012/09/18 (Tue) 01:56:51 _Kyle(1291004) 「いわゆる部分和問題」をExcelで解く-(旧０系：再帰系)

'-----------------------------------------------------------

'■「いわゆる部分和問題」をExcelで解く-(旧０系：再帰系)

'abyssinia.bbs.fc2.com/ act=reply&tid=2850777

'

'  ◆動作仕様

'

'    アクティブシートの

'

'    　・A1セルに目標値

'    　・B1セル以下に要素

'

'    を入力して起動すると

'

'    　・A2セルに発見した解の個数

'    　・C列以降に解

'

'    を書き出します｡

'

'-----------------------------------------------------------

2012/09/22 (Sat) 02:42:26 _Kyle(1291004) - k0SSS_0_51：事前ソート

URL / Comment

'-----------------------------------------------------------

 

'■k0SSS_0_51

'事前ソート

'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5476781

 

'事前に要素をソートして、大きいものから使うというハナシ

 

'-----------------------------------------------------------

  

'■宣言-------------------------------------------

  Private itmAry() As Long      '要素配列

  Private sumAry() As Long      '[後方和]配列

  Private tmpAry() As Boolean   '一時配列

  Private rtnAry   As Variant   '結果配列

  Private orgAry() As Long      '元順配列

  

  Private itmCnt   As Long      '要素個数

  Private rtnCnt   As Long      '結果個数

  Private rtnLmt   As Long      '結果上限

  

  Private endFlg   As Boolean   '終了フラグ

  

'■親Ｐ-------------------------------------------

Sub k0SSS_0_51()

 

  Dim optCel   As Range   '目標値設定セル

  Dim itmCel   As Range   '要素範囲上端セル

  Dim i        As Long

  

  Application.ScreenUpdating = False

  

  Set optCel = Range("A1")

  Set itmCel = Range("B1")

  

  Range(itmCel.Offset(, 1), Cells(Rows.Count, Columns.Count)).ClearContents

  optCel.Offset(1, 0).Clear

  

  itmCnt = Cells(Rows.Count, itmCel.Column).End(xlUp).Row - itmCel.Row + 1

  rtnLmt = Columns.Count - itmCel.Column

  rtnCnt = 0

  endFlg = False

  

  ReDim itmAry(1 To itmCnt)

  ReDim sumAry(1 To itmCnt + 1)

  ReDim tmpAry(1 To itmCnt)

  ReDim orgAry(1 To itmCnt)

  ReDim rtnAry(1 To rtnLmt)

  

  For i = 1 To itmCnt

    itmCel(i, 2).Value = i

  Next i

  

  itmCel.Resize(itmCnt, 2).Sort _

    key1:=itmCel, _

    order1:=xlDescending, _

    Header:=xlNo

  

  For i = itmCnt To 1 Step -1

    itmAry(i) = itmCel(i, 1).Value

    orgAry(i) = itmCel(i, 2).Value

    sumAry(i) = sumAry(i + 1) + itmAry(i)

  Next i

  

  itmCel.Resize(itmCnt, 2).Sort _

    key1:=itmCel(1, 2), _

    order1:=xlAscending, _

    Header:=xlNo

    

  itmCel(1, 2).EntireColumn.ClearContents

  

  Application.EnableCancelKey = xlErrorHandler

 

  Call k0SSS_S(1, optCel.Value)

 

  Call k0SSS_D(optCel, itmCel)

  

  '●終了-------------------------------

  Application.StatusBar = False

  Application.ScreenUpdating = True

  Erase itmAry, tmpAry, rtnAry, sumAry

  

End Sub

 

'■子Ｐ-------------------------------------------

Private Sub k0SSS_S(ByVal itmIdx As Long, ByVal rmnSum As Long)

 

  On Error GoTo handleCancel

  

  Dim i As Long

 

  '[残和]がゼロになったらヒット！

  If rmnSum = 0 Then

    Call k0SSS_H

    Exit Sub

  End If

  

  '[残和]が負になったらアウト！

  If rmnSum < 0 Then Exit Sub

  

  '残りすべてを使っても足りないならアウト！

  If rmnSum > sumAry(itmIdx) Then Exit Sub

  

  '「次」を選ぶ

  For i = itmIdx To itmCnt

    tmpAry(i) = True

    Call k0SSS_S(i + 1, rmnSum - itmAry(i))

    If endFlg Then Exit Sub

    tmpAry(i) = False

  Next i

  

Exit Sub

  

  '●キャンセルトラップ-----------------

handleCancel:

  If k0SSS_C(Err.Number) Then On Error GoTo 0

  Resume

End Sub

 

'■ヒット-------------------------------------------

Private Sub k0SSS_H()

 

  On Error GoTo handleCancel

  

  rtnCnt = rtnCnt + 1

  rtnAry(rtnCnt) = tmpAry

  

  If rtnCnt = 1 Or rtnCnt Mod 10 = 0 Then

    Application.StatusBar = rtnCnt

  End If

  

  endFlg = rtnCnt = rtnLmt

  

Exit Sub

  

  '●キャンセルトラップ-----------------

handleCancel:

  If Err <> 18 Then On Error GoTo 0

  Resume

End Sub

 

'■中断-------------------------------------------

Private Function k0SSS_C(ByRef errNum As Long) As Boolean

 

  If errNum = 18 Then

    Select Case MsgBox("中止？", 515)

      Case vbYes

        endFlg = True

      Case vbNo

        Stop

    End Select

  End If

  

  k0SSS_C = errNum <> 18

  

End Function

 

'■表示-------------------------------------------

Private Sub k0SSS_D(ByRef optCel As Range, ByRef itmCel As Range)

 

  Dim dspAry   As Variant '書出配列

  Dim bufAry() As Boolean '一時配列

  Dim i        As Long

  Dim j        As Long

 

  With optCel.Offset(1, 0)

    .Value = rtnCnt

    If endFlg Then

      .NumberFormatLocal = "0 ""件以上"""

    Else

      .NumberFormatLocal = "0 ""件"""

    End If

  End With

  

  If rtnCnt = 0 Then Exit Sub

  

  ReDim dspAry(1 To itmCnt, 1 To rtnCnt)

  For i = 1 To rtnCnt

    bufAry = rtnAry(i)

    For j = 1 To itmCnt

      If bufAry(j) Then

        dspAry(orgAry(j), i) = itmAry(j)

      End If

    Next j

  Next i

   

  Application.ScreenUpdating = False

  itmCel.Offset(, 1).Resize(itmCnt, rtnCnt).Value = dspAry

  

End Sub

 

'-----------------------------------------------------------

2012/09/21 (Fri) 21:56:21 _Kyle(1291004) - k0SSS_0_41：後方和判定

URL / Comment

'-----------------------------------------------------------

 

'■k0SSS_0_41

'後方和判定

'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5471366

'

'「残りすべてを使っても足りないなら、どうあがいてもアウトよね」

'…というハナシ

  

'-----------------------------------------------------------

  

'■宣言-------------------------------------------

  Private itmAry() As Long      '要素配列

  Private sumAry() As Long      '[後方和]配列

  Private tmpAry() As Boolean   '一時配列

  Private rtnAry   As Variant   '結果配列

  

  Private itmCnt   As Long      '要素個数

  Private rtnCnt   As Long      '結果個数

  Private rtnLmt   As Long      '結果上限

  

  Private endFlg   As Boolean   '終了フラグ

  

'■親Ｐ-------------------------------------------

Sub k0SSS_0_41()

 

  Dim optCel   As Range   '目標値設定セル

  Dim itmCel   As Range   '要素範囲上端セル

  Dim i        As Long

  

  Set optCel = Range("A1")

  Set itmCel = Range("B1")

  

  Range(itmCel.Offset(, 1), Cells(Rows.Count, Columns.Count)).ClearContents

  optCel.Offset(1, 0).ClearContents

  

  itmCnt = Cells(Rows.Count, itmCel.Column).End(xlUp).Row - itmCel.Row + 1

  rtnLmt = Columns.Count - itmCel.Column

  rtnCnt = 0

  endFlg = False

  

  ReDim itmAry(1 To itmCnt)

  ReDim sumAry(1 To itmCnt + 1)

  ReDim tmpAry(1 To itmCnt)

  ReDim rtnAry(1 To rtnLmt)

  

  For i = itmCnt To 1 Step -1

    itmAry(i) = itmCel(i, 1).Value

    sumAry(i) = sumAry(i + 1) + itmAry(i)

  Next i

  

  Application.EnableCancelKey = xlErrorHandler

 

  Call k0SSS_S(1, optCel.Value)

 

  Call k0SSS_D(optCel, itmCel)

  

  '●終了-------------------------------

  Application.StatusBar = False

  Application.ScreenUpdating = True

  Erase itmAry, tmpAry, rtnAry, sumAry

  

End Sub

 

'■子Ｐ-------------------------------------------

Private Sub k0SSS_S(ByVal itmIdx As Long, ByVal rmnSum As Long)

 

  On Error GoTo handleCancel

  

  Dim i As Long

 

  '[残和]がゼロになったらヒット！

  If rmnSum = 0 Then

    Call k0SSS_H

    Exit Sub

  End If

  

  '[残和]が負になったらアウト！

  If rmnSum < 0 Then Exit Sub

  

  '残りすべてを使っても足りないならアウト！

  If rmnSum > sumAry(itmIdx) Then Exit Sub

  

  '「次」を選ぶ

  For i = itmIdx To itmCnt

    tmpAry(i) = True

    Call k0SSS_S(i + 1, rmnSum - itmAry(i))

    If endFlg Then Exit Sub

    tmpAry(i) = False

  Next i

  

Exit Sub

  

  '●キャンセルトラップ-----------------

handleCancel:

  If k0SSS_C(Err.Number) Then On Error GoTo 0

  Resume

End Sub

 

'■ヒット-------------------------------------------

Private Sub k0SSS_H()

 

  On Error GoTo handleCancel

  

  rtnCnt = rtnCnt + 1

  rtnAry(rtnCnt) = tmpAry

  

  If rtnCnt = 1 Or rtnCnt Mod 10 = 0 Then

    Application.StatusBar = rtnCnt

  End If

  

  endFlg = rtnCnt = rtnLmt

  

Exit Sub

  

  '●キャンセルトラップ-----------------

handleCancel:

  If Err <> 18 Then On Error GoTo 0

  Resume

End Sub

 

'■中断-------------------------------------------

Private Function k0SSS_C(ByRef errNum As Long) As Boolean

 

  If errNum = 18 Then

    Select Case MsgBox("中止？", 515)

      Case vbYes

        endFlg = True

      Case vbNo

        Stop

    End Select

  End If

  

  k0SSS_C = errNum <> 18

  

End Function

 

'■表示-------------------------------------------

Private Sub k0SSS_D(ByRef optCel As Range, ByRef itmCel As Range)

  

  Dim dspAry   As Variant '書出配列

  Dim i        As Long

  Dim j        As Long

  Dim k        As Long

  

  With optCel.Offset(1, 0)

    .Value = rtnCnt

    If endFlg Then

      .NumberFormatLocal = "0 ""件以上"""

    Else

      .NumberFormatLocal = "0 ""件"""

    End If

  End With

    

  optCel.Offset(1, 0).Value = rtnCnt

    

  If rtnCnt = 0 Then Exit Sub

    

  ReDim dspAry(1 To itmCnt, 1 To rtnCnt)

    

  For i = 1 To rtnCnt

    For j = 1 To itmCnt

      If rtnAry(i)(j) Then

        dspAry(j, i) = itmAry(j)

      End If

    Next j

  Next i

    

  itmCel.Offset(, 1).Resize(itmCnt, rtnCnt).Value = dspAry

    

End Sub

 

'-----------------------------------------------------------

2012/09/18 (Tue) 21:10:55 _Kyle(1291004) - k0SSS_0_31：真面目に書く

URL / Comment

'-----------------------------------------------------------

 

'■k0SSS_0_31

'真面目に書く

'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5409000

'

'同じアルゴリズム，同じ再帰回数でも

'コーディング次第で結構違ってくるというハナシ

 

'-----------------------------------------------------------

   

'■宣言-------------------------------------------

  Private itmAry() As Long      '要素配列

  Private tmpAry() As Boolean   '一時配列

  Private rtnAry   As Variant   '結果配列

   

  Private itmCnt   As Long      '要素個数

  Private rtnCnt   As Long      '結果個数

  Private rtnLmt   As Long      '結果上限

   

  Private endFlg   As Boolean   '終了フラグ

   

'■親Ｐ-------------------------------------------

Sub k0SSS_0_31()

 

  Dim optCel   As Range   '目標値設定セル

  Dim itmCel   As Range   '要素範囲上端セル

  Dim i        As Long

   

  Set optCel = Range("A1")

  Set itmCel = Range("B1")

   

  Range(itmCel.Offset(, 1), Cells(Rows.Count, Columns.Count)).ClearContents

  optCel.Offset(1, 0).ClearContents

   

  itmCnt = Cells(Rows.Count, itmCel.Column).End(xlUp).Row - itmCel.Row + 1

  rtnLmt = Columns.Count - itmCel.Column

  rtnCnt = 0

  endFlg = False

   

  ReDim itmAry(1 To itmCnt)

  ReDim tmpAry(1 To itmCnt)

  ReDim rtnAry(1 To rtnLmt)

   

  For i = 1 To itmCnt

    itmAry(i) = itmCel(i, 1).Value

  Next i

   

  Application.EnableCancelKey = xlErrorHandler

 

  Call k0SSS_S(1, optCel.Value)

 

  Call k0SSS_D(optCel, itmCel)

   

  '●終了-------------------------------

  Application.StatusBar = False

  Application.ScreenUpdating = True

  Erase itmAry, tmpAry, rtnAry

   

End Sub

 

'■子Ｐ-------------------------------------------

Private Sub k0SSS_S(ByVal itmIdx As Long, ByVal rmnSum As Long)

 

  On Error GoTo handleCancel

   

  Dim i As Long

 

  '[残和]がゼロになったらヒット！

  If rmnSum = 0 Then

    Call k0SSS_H

    Exit Sub

  End If

   

  '[残和]が負になったらアウト！

  If rmnSum < 0 Then Exit Sub

   

  '「次」を選ぶ

  For i = itmIdx To itmCnt

    tmpAry(i) = True

    Call k0SSS_S(i + 1, rmnSum - itmAry(i))

    If endFlg Then Exit Sub

    tmpAry(i) = False

  Next i

   

Exit Sub

   

  '●キャンセルトラップ-----------------

handleCancel:

  If k0SSS_C(Err.Number) Then On Error GoTo 0

  Resume

End Sub

 

'■ヒット-------------------------------------------

Private Sub k0SSS_H()

 

  On Error GoTo handleCancel

   

  rtnCnt = rtnCnt + 1

  rtnAry(rtnCnt) = tmpAry

   

  If rtnCnt = 1 Or rtnCnt Mod 10 = 0 Then

    Application.StatusBar = "探索中　解：　" & rtnCnt & "　件"

  End If

   

  endFlg = rtnCnt = rtnLmt

   

Exit Sub

   

  '●キャンセルトラップ-----------------

handleCancel:

  If Err <> 18 Then On Error GoTo 0

  Resume

End Sub

 

'■中断-------------------------------------------

Private Function k0SSS_C(ByRef errNum As Long) As Boolean

 

  If errNum = 18 Then

    Select Case MsgBox("中止？", 515)

      Case vbYes

        endFlg = True

      Case vbNo

        Stop

    End Select

  End If

   

  k0SSS_C = errNum <> 18

   

End Function

 

'■表示------------------------------------------- 

Private Sub k0SSS_D(ByRef optCel As Range, ByRef itmCel As Range)

 

  Dim dspAry   As Variant '書出配列

  Dim i        As Long

  Dim j        As Long

  Dim k        As Long

 

  With optCel.Offset(1, 0)

    .Value = rtnCnt

    If endFlg Then

      .NumberFormatLocal = "0 ""件以上"""

    Else

      .NumberFormatLocal = "0 ""件"""

    End If

  End With

   

  optCel.Offset(1, 0).Value = rtnCnt

   

  If rtnCnt = 0 Then Exit Sub

   

  ReDim dspAry(1 To itmCnt, 1 To rtnCnt)

   

  For i = 1 To rtnCnt

    For j = 1 To itmCnt

      If rtnAry(i)(j) Then

        dspAry(j, i) = itmAry(j)

      End If

    Next j

  Next i

   

  itmCel.Offset(, 1).Resize(itmCnt, rtnCnt).Value = dspAry

   

End Sub

 

'-----------------------------------------------------------

2012/09/18 (Tue) 19:52:31 _Kyle(1291004) - k0SSS_0_21：素朴再帰

URL / Comment

'-----------------------------------------------------------

  

'■k0SSS_0_21

'素朴再帰

'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5400052

'

'「使うか否か」ではなく「次に使うもの」で分岐

'普通はこの辺が叩き台になると思います。

'

'-----------------------------------------------------------

    

'■宣言-----------------------

  Private itmAry   As Variant   '[要素]配列

  Private itmCnt   As Integer   '[要素]個数

  Private rtnAry() As Long      '結果配列

  Private rtnCnt   As Long      '結果個数

  Private rtnLmt   As Long      '結果上限

    

  Private optCel   As Range     '[目標値]設定セル

  Private itmCel   As Range     '[要素]範囲上端セル

    

'■親Ｐ-----------------------

Sub k0SSS_0_21()

  

  Set optCel = Range("A1")

  Set itmCel = Range("B1")

    

  Range(itmCel.Offset(, 1), Cells(Rows.Count, Columns.Count)).ClearContents

  itmCnt = Cells(Rows.Count, itmCel.Column).End(xlUp).Row - itmCel.Row + 1

  itmAry = itmCel.Resize(itmCnt, 1).Value

  rtnLmt = Columns.Count - itmCel.Column

      

  ReDim rtnAry(1 To itmCnt, 1 To 1)

      

  rtnCnt = 0

  Call k0SSS_S(1, optCel.Value)

    

  optCel.Offset(1, 0).Value = rtnCnt

  

End Sub

  

'■子Ｐ-----------------------

Private Sub k0SSS_S(ByVal itmIdx As Integer, ByVal rmnSum As Long)

  

  Dim i As Integer

  

  '[残和]がゼロならヒット！

  If rmnSum = 0 Then

    rtnCnt = rtnCnt + 1

    itmCel.Offset(, rtnCnt).Resize(itmCnt, 1).Value = rtnAry

    If rtnCnt = rtnLmt Then End

    Exit Sub

  End If

    

  '[残和]が負ならアウト！

  If rmnSum < 0 Then Exit Sub

    

  '「次に使うもの」を選ぶ

  For i = itmIdx To itmCnt

    rtnAry(i, 1) = itmAry(i, 1)

    Call k0SSS_S(i + 1, rmnSum - itmAry(i, 1))

    rtnAry(i, 1) = 0

  Next i

      

End Sub

  

'-----------------------------------------------------------

2012/09/18 (Tue) 08:26:04 _Kyle(1291004) - k0SSS_0_10：原始再帰

URL / Comment

'-----------------------------------------------------------

 

'■k0SSS_0_10

'原始再帰

'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5397632

'

'「いわゆる部分和問題」を再帰処理で解く【最も原始的な】カタチです。

'これより遅いコードはジョークコード認定ってことでw

 

'-----------------------------------------------------------

  

'■宣言-----------------------

  Private itmAry   As Variant   '[要素]配列

  Private itmCnt   As Integer   '[要素]個数

  Private rtnAry() As Long      '結果配列

  Private rtnCnt   As Integer   '結果個数

  Private rtnLmt   As Long      '結果上限

  

  Private optCel   As Range     '[目標値]設定セル

  Private itmCel   As Range     '[要素]範囲上端セル

  

'■親Ｐ-----------------------

Sub k0SSS_0_10()

 

  Set optCel = Range("A1")

  Set itmCel = Range("B1")

 

  Range(itmCel.Offset(, 1), Cells(Rows.Count, Columns.Count)).ClearContents

  itmCnt = Cells(Rows.Count, itmCel.Column).End(xlUp).Row - itmCel.Row + 1

  itmAry = itmCel.Resize(itmCnt, 1).Value

  rtnLmt = Columns.Count - itmCel.Column

    

  ReDim rtnAry(1 To itmCnt, 1 To 1)

    

  rtnCnt = 0

  Call k0SSS_S(1, optCel.Value)

  

  optCel.Offset(1, 0).Value = rtnCnt

 

End Sub

 

'■子Ｐ-----------------------

Private Sub k0SSS_S(ByVal itmIdx As Integer, ByVal rmnSum As Long)

 

  'まず[残和]を調べてヒット判定

  If rmnSum = 0 Then

    rtnCnt = rtnCnt + 1

    itmCel.Offset(, rtnCnt).Resize(itmCnt, 1).Value = rtnAry

    If rtnCnt = rtnLmt Then End

    Exit Sub

  End If

  

  '[残和]が負ならアウト！

  If rmnSum < 0 Then Exit Sub

  

  '要素を使い切ったらアウト！

  If itmIdx > itmCnt Then Exit Sub

    

  '使って次へ

  rtnAry(itmIdx, 1) = itmAry(itmIdx, 1)

  Call k0SSS_S(itmIdx + 1, rmnSum - itmAry(itmIdx, 1))

  

  '使わず次へ

  rtnAry(itmIdx, 1) = 0

  Call k0SSS_S(itmIdx + 1, rmnSum)

    

End Sub

 

'-----------------------------------------------------------

2012/09/18 (Tue) 01:59:58 _Kyle(1291004) - k0SSS_0_00：再帰でなぜか総当り

URL / Comment

'=====↓ココカラ↓==========================================

 

'■k0SSS_0_00

'再帰で【なぜか】総当り

'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5392769

'

'再帰でやるなら、

'わざわざ総当りする理由なんて、これっぽっちもないんですが。

 

'-------------------------------------------------

   

'■宣言-----------------------

  Private itmAry   As Variant   '[要素]配列

  Private itmCnt   As Integer   '[要素]個数

  Private rtnAry() As Long      '結果配列

  Private rtnCnt   As Integer   '結果個数

  Private rtnLmt   As Integer   '結果上限

   

  Private optCel   As Range     '[目標値]設定セル

  Private itmCel   As Range     '[要素]範囲上端セル

   

'■親Ｐ-----------------------

Sub k0SSS_0_00()

 

  Set optCel = Range("A1")

  Set itmCel = Range("B1")

 

  Range(itmCel.Offset(, 1), Cells(Rows.Count, Columns.Count)).ClearContents

  itmCnt = Cells(Rows.Count, itmCel.Column).End(xlUp).Row - itmCel.Row + 1

  itmAry = itmCel.Resize(itmCnt, 1).Value

  rtnLmt = Columns.Count - itmCel.Column

     

  ReDim rtnAry(1 To itmCnt, 1 To 1)

     

  rtnCnt = 0

  Call k0SSS_S(1, optCel.Value)

   

  optCel.Offset(1, 0).Value = rtnCnt

   

End Sub

 

'■子Ｐ-----------------------

Private Sub k0SSS_S(ByVal itmIdx As Integer, ByVal rmnSum As Long)

 

  '「底」判定

  If itmIdx > itmCnt Then

   

    'ヒット判定

    If rmnSum = 0 Then

      rtnCnt = rtnCnt + 1

      itmCel.Offset(, rtnCnt).Resize(itmCnt, 1).Value = rtnAry

      If rtnCnt = rtnLmt Then

        optCel.Offset(1, 0).Value = rtnCnt

        End

      End If

    End If

     

    Exit Sub

     

  End If

     

  '使って次へ

  rtnAry(itmIdx, 1) = itmAry(itmIdx, 1)

  Call k0SSS_S(itmIdx + 1, rmnSum - itmAry(itmIdx, 1))

   

  '使わず次へ

  rtnAry(itmIdx, 1) = 0

  Call k0SSS_S(itmIdx + 1, rmnSum)

     

End Sub

'=====↑ココマデ↑==========================================

Name		Password
Subject

Preview