Excel VBA質問箱 IV

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

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


39373 / 76732 ←次へ | 前へ→

【42472】Re:組合せ
回答  ナイスプログラム WEB  - 06/9/13(水) 1:07 -

引用なし
パスワード
    今晩は。

 難しかったですが、何とか出来ました。バグがあるかも知れないので、テストして
下さい。

【使い方】
a列の上から下に掛けて組み合わせる数字を書く。
b1に合計する数を書く。(この場合74)。
下記コードを標準モジュールに書いて動かす。

【コード】

Option Explicit
Option Base 1

Dim sinki As Object
Dim ii() As Integer
Dim index As Integer, ic As Integer


Sub 合計()

ThisWorkbook.Worksheets(1).Copy
Set sinki = ActiveWorkbook

ReDim ii(Range("a65536").End(xlUp).Row)
ic = 3

index = 0
Range("A1").Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess

Call 計算(1, Range("b1").Value)

End Sub

Private Sub 計算(ByVal i1 As Integer, ans2 As Integer)

Dim i As Integer

Cells(i1, 1).Select


If i1 > UBound(ii) Then
  If ii(index) = UBound(ii) Then
    index = index - 1
    If index = 0 Then Exit Sub
  End If
    
  ii(index) = ii(index) + 1
  
  ans2 = Range("b1").Value
  For i = 1 To index
    ans2 = ans2 - Cells(ii(i), 1)
    
  Next

  Call 計算(ii(index) + 1, ans2)
Else

  ans2 = ans2 - Cells(i1, 1).Value
  Select Case ans2
    Case Is > 0
      index = index + 1
      ii(index) = i1
    
      Call 計算(i1 + 1, ans2)
    Case 0
      ic = ic + 1
      index = index + 1
      ii(index) = i1
      For i = 1 To index
        Cells(i, ic).Value = Cells(ii(i), 1).Value
      Next
    
      ans2 = ans2 + Cells(i1, 1).Value
      index = index - 1
      Call 計算(i1 + 1, ans2)
    Case Is < 0
      ans2 = ans2 + Cells(i1, 1).Value
      Call 計算(i1 + 1, ans2)
    End Select

End If

End Sub

0 hits

【42432】組合せ 教えてください 06/9/11(月) 23:32 質問
【42467】Re:組合せ [名前なし] 06/9/12(火) 21:05 発言
【42471】Re:組合せ 漂流民 06/9/13(水) 0:24 発言
【42472】Re:組合せ ナイスプログラム 06/9/13(水) 1:07 回答
【42473】Re:組合せ ichinose 06/9/13(水) 6:37 発言
【42529】Re:組合せ ナイスプログラム 06/9/13(水) 21:58 回答
【42556】Re:組合せ 教えてください 06/9/14(木) 23:04 お礼

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