Excelで、指定した合計値(または近似値)の複数セルを自動選択する方法

質問

http://okwave.jp/qa1243434.htmlとほぼ同じなのですが、
選択するセルの数を指定しない場合のマクロの書き方を教えていただきたいです。

上URLのマクロではMaxUseを指定しないと計算が出来ませんでした。

回答No.1

_Kyle · ベストアンサー

とりあえず叩き台として。

スクラッチから書きましたので、
qa1243434のコードとは別個のプログラムとお考えください。

A1セル以下に元リスト、B1セルに目標値を入力して起動すると、
合計が目標値に最も近くなる組合せを探して選択します。

今回、速度はあまり重視していませんが、
元リストの個数が数千個程度であれば、
概ね数秒以内で最適解を発見できるハズです。

Excel2003で動作確認。以上ご参考まで。

'==========================↓　ココカラ　↓==========================
　Dim itmCnt　　　　As Long
　Dim itmAry()　　　As Long
　Dim sumAry()　　　As Long
　Dim tmpAry()　　　As Boolean
　Dim difCnt　　　　As Long
　Dim rvsFlg　　　　As Boolean
　Dim hitFlg　　　　As Boolean
'------------↓↑　ツヅク　↑↓------------
Sub Subset_sum()
　Dim orgAry　　　　As Variant
　Dim tgtSum　　　　As Long
　Dim i　　　　　　 As Long

　'目標値
　tgtSum = Cells(1, 2).Value
　'元リスト要素数
　itmCnt = Cells(Rows.Count, 1).End(xlUp).Row
　'元リスト
　orgAry = Cells(1, 1).Resize(itmCnt).Value

　ReDim itmAry(0 To itmCnt)
　ReDim tmpAry(1 To itmCnt)
　ReDim sumAry(1 To itmCnt + 1)
　For i = itmCnt To 1 Step -1
　　itmAry(i) = orgAry(i, 1)
　　sumAry(i) = sumAry(i + 1) + itmAry(i)
　Next i
　rvsFlg = sumAry(1) / 2 < tgtSum
　If rvsFlg Then tgtSum = sumAry(1) - tgtSum
　hitFlg = False
　difCnt = 0
　Call SS_rft(0, tgtSum)
　If Not hitFlg Then
　　For difCnt = 1 To tgtSum
　　　Call SS_rft(0, tgtSum + difCnt)
　　　Call SS_rft(0, tgtSum - difCnt)
　　　If hitFlg Then Exit For
　　Next difCnt
　End If
　MsgBox _
　　"探索が終了しました" & vbLf & _
　　"現在選択されている組合せが最適解です" & vbLf & vbLf & _
　　"目標値との差は　【　" & difCnt & "　】　です"
End Sub
'------------↓↑　ツヅク　↑↓------------
Private Sub SS_rft(ByVal itmIdx As Long, ByVal tmpSum As Long)
　Dim i As Long
　tmpSum = tmpSum - itmAry(itmIdx)
　If tmpSum = 0 Then Call SS_hit
　If tmpSum <= 0 Then Exit Sub
　For i = itmIdx + 1 To itmCnt
　　If sumAry(i) < tmpSum Then Exit Sub
　　tmpAry(i) = True
　　Call SS_rft(i, tmpSum)
　　tmpAry(i) = False
　Next i
End Sub
'------------↓↑　ツヅク　↑↓------------
Private Sub SS_hit()
　Dim myRng As Range
　Dim i　　 As Long
　hitFlg = True
　For i = 1 To itmCnt
　　If rvsFlg <> tmpAry(i) Then
　　　If myRng Is Nothing Then
　　　　Set myRng = Cells(i, 1)
　　　Else
　　　　Set myRng = Union(myRng, Cells(i, 1))
　　　End If
　　End If
　Next i
　myRng.Select
　ActiveWindow.ScrollRow = 1
　If MsgBox( _
　　"最適解を発見しました" & vbLf & _
　　"目標値との差は　【　" & difCnt & "　】　です" & vbLf & vbLf & _
　　"続行して他の最適解を探索しますか？", _
　　vbYesNo) <> vbYes Then End
End Sub
'==========================↑　ココマデ　↑==========================

お礼

回答ありがとうございます。
セル値を変えてもエラー無く実行することが出来ました。