URL /
Comment
'-----------------------------------------------------------
'■「いわゆる部分和問題」をExcelで解く-(旧９系：総当り系)
'abyssinia.bbs.fc2.com/ act=reply&tid=2850777
'
' ◆動作仕様
'
' アクティブシートの
'
' ・A1セルに目標値
' ・B1セル以下に要素
'
' を入力して起動すると
'
' ・A2セルに発見した解の個数
' ・C列以降に解
'
' を書き出します｡
'
' ※ジョークコードです。念のため。
'
'-----------------------------------------------------------
URL /
Comment
'=====↓ココカラ↓==========================================
'■k0SSS_9_10
'総当りその３ 胡乱な総当り
'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5395317
'
'要素数が30を超えても動作しますが
'速度的に実用になるかといえば、ソレはまた別のハナシ (^^;;;;;;;
'-----------------------------------------------------------
Sub k0SSS_9_10()
Dim optCel As Range '[目標値]設定セル
Dim itmCel As Range '[要素]範囲上端セル
Dim itmCnt As Long '[要素]個数
Dim itmAry() As Long '[要素]配列
Dim tgtSum As Long '[目標値]
Dim tmpSum As Long '[暫定和]
Dim tmpAry() As Boolean '結果配列
Dim rtnCnt As Long '結果個数
Dim rtnLmt As Long '結果上限
Dim i As Long
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
rtnLmt = Columns.Count - itmCel.Column
tgtSum = optCel.Value
ReDim itmAry(1 To itmCnt)
ReDim tmpAry(1 To itmCnt)
For i = 1 To itmCnt
itmAry(i) = itmCel(i, 1).Value
Next i
Do
'"加算"
For i = 1 To itmCnt + 1
If i = itmCnt + 1 Then Exit Do
If tmpAry(i) Then
tmpAry(i) = False
tmpSum = tmpSum - itmAry(i)
Else
tmpAry(i) = True
tmpSum = tmpSum + itmAry(i)
Exit For
End If
Next i
'判定
If tmpSum = tgtSum Then
rtnCnt = rtnCnt + 1
For i = 1 To itmCnt
If tmpAry(i) Then
itmCel(i, rtnCnt + 1).Value = itmAry(i)
End If
Next i
End If
Loop
End Sub
'=====↑ココマデ↑==========================================
URL /
Comment
'=====↓ココカラ↓==========================================
'■k0SSS_9_01
'総当りその２ アリガチな総当り 改
'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5394674
'abyssinia.bbs.fc2.com/ act=reply&tid=2850777#5396458
'
'元コード
'www.geocities.co.jp/SiliconValley-Oakland/8139/
'
'Long型の制限のため、要素数の上限は30です。
'PC買い換えてもダメですw
'-------------------------------------------------
'■宣言-----------------------
Private itmAry(1 To 30) As Long '[要素]配列
'■本体-----------------------
Sub k0SSS_9_01()
Dim optCel As Range '[目標値]設定セル
Dim itmCel As Range '[要素]範囲上端セル
Dim itmCnt As Long '[要素]個数
Dim tgtSum As Long '[目標値]
Dim tmpSum As Long '[暫定和]
Dim itmIdx As Long '2^([要素]番号-1)
Dim rtnCnt As Long '結果個数
Dim rtnLmt As Long '結果上限
Dim i As Long
Dim j As Long
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
rtnLmt = Columns.Count - itmCel.Column
For i = 1 To itmCnt
itmAry(i) = itmCel(i, 1).Value
Next i
tgtSum = optCel.Value
'総組合せ数分回す
For i = 1 To 2 ^ itmCnt - 1
'iの各ビットを「読んで」足し上げる
itmIdx = 1
tmpSum = 0
For j = 1 To itmCnt
If i And itmIdx Then tmpSum = tmpSum + itmAry(j)
itmIdx = itmIdx + itmIdx
Next
'ヒット判定
If tmpSum = tgtSum Then
rtnCnt = rtnCnt + 1
itmIdx = 1
For j = 1 To itmCnt
If i And itmIdx Then itmCel(j, rtnCnt + 1).Value = itmAry(j)
itmIdx = itmIdx + itmIdx
Next j
If rtnCnt = rtnLmt Then Exit For
End If
Next i
optCel.Offset(1, 0).Value = rtnCnt
End Sub
'=====↑ココマデ↑==========================================