Excel VBA質問箱 IV

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

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


13275 / 13644 ツリー ←次へ | 前へ→

【6113】複数の数値の合計が指定した数になるようにしたいのですが・・・ よしこ 03/6/16(月) 22:03 質問
【6151】Re:複数の数値の合計が指定した数になるよう... LC 03/6/17(火) 18:19 質問
【6153】Re:複数の数値の合計が指定した数になるよ... よしこ 03/6/17(火) 20:39 質問
【6157】Re:複数の数値の合計が指定した数になるよ... LC 03/6/17(火) 23:08 発言
【6159】Re:複数の数値の合計が指定した数になるよ... よしこ 03/6/18(水) 0:46 お礼
【6161】Re:複数の数値の合計が指定した数になるよ... LC 03/6/18(水) 6:24 質問
【6179】Re:複数の数値の合計が指定した数になるよ... LC 03/6/18(水) 12:30 回答
【6182】Re:複数の数値の合計が指定した数になるよ... ichinose 03/6/18(水) 12:45 発言
【6192】Re:複数の数値の合計が指定した数になるよ... よしこ 03/6/18(水) 21:52 お礼

【6113】複数の数値の合計が指定した数になるよう...
質問  よしこ  - 03/6/16(月) 22:03 -

引用なし
パスワード
   下のように、A列に数値がいくつも入力されていて複数の数値の合計が
指定した数(例えば50)になるような組み合わせを1つ取り出し適当な
ところに貼り付けをする。
また、削除ボタンを押すとA列から該当する数値が削除されるようにし
たいと思います。

VBAは、マクロの記録でしか行ったことがありません
どうかよろしくお願いいたします。

A列  B  C  D

       50 (指定した数)
2      
11
14
25
9
44

【6151】Re:複数の数値の合計が指定した数になるよ...
質問  LC  - 03/6/17(火) 18:19 -

引用なし
パスワード
   ▼よしこ さん:

こんにちわ。

組み合わせる数値の個数は決まっていますか?
例の場合、11,14,25の3つですよね。
20,30のように2つもありですか?
3つと決まっている方が簡単ですけどね。

あと、どう組み合わせても、指定した数(50)にならない場合がありますか?
必ず50になる組み合わせがあるのでしょうか?

【6153】Re:複数の数値の合計が指定した数になるよ...
質問  よしこ  - 03/6/17(火) 20:39 -

引用なし
パスワード
   ▼LC さん:

こんにちわ。
さそっくの返事ありがとうございます。


組み合わせる個数は決まっていません。

>20,30のように2つもありですか?

はい。2つの場合もあるしそれ以上の場合も当然あります。

>あと、どう組み合わせても、指定した数(50)にならない場合がありますか?
>必ず50になる組み合わせがあるのでしょうか?

A列に入力されている数値が少ない時は、指定した数(50) にならない場合
もあります。入力されている数値が多い時は、2つの場合もあるしそれ以上
の場合も当然あります。(できるだけ組み合わせる個数は少なくしたい。)

【6157】Re:複数の数値の合計が指定した数になるよ...
発言  LC  - 03/6/17(火) 23:08 -

引用なし
パスワード
   ▼よしこ さん:

こんばんわ。
かなーりファットでよろしくないんですけど、作ってみました。
とりあえず、こんな感じはどうかな?ってのをアップします。
よくないところとか、他に希望などありましたら言ってください。

条件)
データはA1〜ずらーっとあること
合計値(例の場合50)がC1に入力されていること
H列とZ列には何も入力されていないこと

結果は?)
マクロを実行すると、H列に文字列が表示されます。(とりあえずです)
※データの個数は2つの合計か3つの合計しかできません。。(とりあえず。。)

マクロ)
以下のコードを標準モジュールに記述して、対象のシートをアクティブにし、
マクロ(合計を合わせる)を実行する。

Dim a As Integer, k As Integer
Private Sub ランダム合計2個()

  Dim b As Integer, c As Integer, d As Integer, e As Integer
  Dim f As Integer, g As Integer, h As Integer
  

  'A列の最終行を取得
  a = Range("A65536").End(xlUp).Row
  '合計値を格納
  h = Range("C1")
  
  '合計値になるまで繰り返す。"k"回繰り返し合計値にならなかったら抜ける
  Do Until g = h Or k = a * 50
  
    'Z4に数値が入力されるまで繰り返す
    Do
      'ランダムな整数値を格納
      b = Int(a * Rnd) + 1
      'C列の最終行を取得
      c = Range("Z65536").End(xlUp).Row
      
      '同じ数値がないか検索------------------------
      With Range("Z2:Z3")
        Set Rng = .Find(What:=b, MatchCase:=False)
      End With
      If Rng Is Nothing Then Range("Z" & c + 1) = b
      '-------------------------------------------
      
    Loop Until Range("Z3") <> ""
  
    d = Range("Z2")
    e = Range("Z3")
    
    g = Range("A" & d) + Range("A" & e)
    
    Range("H1") = d & "行目の" & Range("A" & d)
    Range("H2") = e & "行目の" & Range("A" & e)
    
    Range("Z2").Clear
    Range("Z3").Clear
 
    k = k + 1
    
  Loop


End Sub
Private Sub ランダム合計3個()

  Dim b As Integer, c As Integer, d As Integer, e As Integer
  Dim f As Integer, g As Integer, h As Integer
  

  '合計値を格納
  h = Range("C1")
  
  '合計値になるまで繰り返す。"k"回繰り返し合計値にならなかったら抜ける
  Do Until g = h Or k = a * 50
  
    'Z4に数値が入力されるまで繰り返す
    Do
      'ランダムな整数値を格納
      b = Int(a * Rnd) + 1
      'C列の最終行を取得
      c = Range("Z65536").End(xlUp).Row
      
      '同じ数値がないか検索------------------------
      With Range("Z2:Z4")
        Set Rng = .Find(What:=b, MatchCase:=False)
      End With
      If Rng Is Nothing Then Range("Z" & c + 1) = b
      '-------------------------------------------
      
    Loop Until Range("Z4") <> ""
  
    d = Range("Z2")
    e = Range("Z3")
    f = Range("Z4")
    
    g = Range("A" & d) + Range("A" & e) + Range("A" & f)
    
    Range("H1") = d & "行目の" & Range("A" & d)
    Range("H2") = e & "行目の" & Range("A" & e)
    Range("H3") = f & "行目の" & Range("A" & f)
    
    Range("Z2").Clear
    Range("Z3").Clear
    Range("Z4").Clear
    
    k = k + 1
    
  Loop
  
End Sub
Sub 合計を合わせるマクロ()

  Columns("H:H").Clear
  Columns("Z:Z").Clear

  Call ランダム合計2個
  If k = a * 50 Then
    k = 0
    Call ランダム合計3個
  End If
  
  If k = a * 50 Then
    MsgBox "合計値になりません。。"
    Columns("H:H").Clear
  End If
  
  k = 0
    
End Sub

【6159】Re:複数の数値の合計が指定した数になるよ...
お礼  よしこ  - 03/6/18(水) 0:46 -

引用なし
パスワード
   ▼LC さん:

私の無理なお願いを聞いていただき、どうもありがとうございます。
できました。感謝、感謝です。(*^_^*)

【6161】Re:複数の数値の合計が指定した数になるよ...
質問  LC  - 03/6/18(水) 6:24 -

引用なし
パスワード
   ▼よしこ さん:
>▼LC さん:
>
>私の無理なお願いを聞いていただき、どうもありがとうございます。
>できました。感謝、感謝です。(*^_^*)

あれだけでいいのかな?
削除ボタンはいいですか?

【6179】Re:複数の数値の合計が指定した数になるよ...
回答  LC  - 03/6/18(水) 12:30 -

引用なし
パスワード
   ▼よしこ さん:

こんにちわ。
前のマクロを改造しました。
でも3つの組み合わせの場合だと、あまり使えませんね。

詳細)
2つの組み合わせだと全パターン調べることができます。
3つの組み合わせは全パターン調べるわけではないので、
みつけられないこともあります。
マクロ中の*50の値を変更すれば確率が変わります。
*10にした場合、確率は低くなりますが、なかった場合のマクロ終了までの時間が短くなります。
*80にした場合、確率は高くなりますが、なかった場合のマクロ終了までの時間が長くなります。

以下、標準モジュールに記述して下さい。

Dim a As Integer, k As Integer
Private Sub ランダム合計2個()

  Dim b As Integer, c As Integer, i As Integer, j As Integer

  a = Range("A65536").End(xlUp).Row
  c = Range("C1")
  
  For j = 1 To a
  
    b = c - Range("A" & j)
    
    For i = j + 1 To a
      If Range("A" & i) = b Then
        k = 9
        Exit For
      End If
    Next
    
    If k = 9 Then Exit For
    
  Next


  If k <> 9 Then
    MsgBox "2つの組み合わせはありません。続いて3つの組み合わせで探します。"
  Else
    Range("H1") = j & "行目の" & Range("A" & j)
    Range("H2") = i & "行目の" & Range("A" & i)
  End If


End Sub
Private Sub ランダム合計3個()

  Dim b As Integer, c As Integer, d As Integer, e As Integer
  Dim f As Integer, g As Integer, h As Integer
  

  '合計値を格納
  h = Range("C1")
  
  '合計値になるまで繰り返す。"k"回繰り返し合計値にならなかったら抜ける
  Do Until g = h Or k = a * 50
  
    'Z4に数値が入力されるまで繰り返す
    Do
      'ランダムな整数値を格納
      b = Int(a * Rnd) + 1
      'C列の最終行を取得
      c = Range("Z65536").End(xlUp).Row
      
      '同じ数値がないか検索------------------------
      With Range("Z2:Z4")
        Set Rng = .Find(What:=b, MatchCase:=False)
      End With
      If Rng Is Nothing Then Range("Z" & c + 1) = b
      '-------------------------------------------
      
    Loop Until Range("Z4") <> ""
  
    d = Range("Z2")
    e = Range("Z3")
    f = Range("Z4")
    
    g = Range("A" & d) + Range("A" & e) + Range("A" & f)
    
    Range("H1") = d & "行目の" & Range("A" & d)
    Range("H2") = e & "行目の" & Range("A" & e)
    Range("H3") = f & "行目の" & Range("A" & f)
    
    Range("Z2").Clear
    Range("Z3").Clear
    Range("Z4").Clear
    
    k = k + 1
    
  Loop
  
End Sub
Sub 合計を合わせるマクロ()

  Columns("H:H").Clear
  Columns("Z:Z").Clear

  Call ランダム合計2個
  If k <> 9 Then Call ランダム合計3個

  If k = a * 50 Then
    MsgBox "合計値になる組み合わせはなさそうです。。"
    Columns("H:H").Clear
  End If
  
  k = 0
    
End Sub

【6182】Re:複数の数値の合計が指定した数になるよ...
発言  ichinose  - 03/6/18(水) 12:45 -

引用なし
パスワード
   ▼LC さん:
▼よしこ さん:
こんにちは。
前に組み合わせのご質問があったときに作ったコードをそのまま使いました。
「A列の組み合わせ合計がセルC1と同じになった値をD列に貼り付けました」
標準モジュールに
'=======================================================
Dim ans_rng As Range
Sub main()
  Dim rng As Range
  Dim ans()
  Dim 抜取数 As Long
  Dim ques
  Dim mysum
  Set ans_rng = Nothing
  ques = Range("c1").Value
  Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
  見つけた = False
  For 抜取数 = 1 To rng.Count
   cnt = comb(ans(), rng, 抜取数)
   For idx = 1 To cnt
    mysum = 0
    For jdx = 1 To 抜取数
     mysum = mysum + ans(idx, jdx)
     Next jdx
    If mysum = ques Then
      For kdx = 1 To 抜取数
       If ans_rng Is Nothing Then
        Set ans_rng = rng.Cells(WorksheetFunction.Match(ans(idx, kdx), rng, 0))
       Else
        Set ans_rng = Union(ans_rng, rng.Cells(WorksheetFunction.Match(ans(idx, kdx), rng, 0)))
        End If
       Next kdx
      Exit For
      End If
    Next idx
   If Not ans_rng Is Nothing Then Exit For
   Next 抜取数
  If Not ans_rng Is Nothing Then
    MsgBox "見つけた"
    ans_rng.Copy Range("d1")
  Else
    MsgBox "駄目だった"
    End If
End Sub
'========================================================================
Function comb(ans(), Optional rng As Range = Nothing, Optional seln As Long = 0, Optional ByVal myx As Long = 0, Optional ByVal ctx As Long = 0) As Long
'input rng : 組み合わせメンバーセル範囲
'   seln: 抜き取り数
'out  ans() 組み合わせリスト
'   mxy ctx は 内部パラメータ指定不可
  Dim crng As Range
  Static svn As Long
  Static myarray()
  Static idx As Long
  Static gyou As Long
  Static mylim As Long
  Dim cnt As Long
  If seln > 0 Then
    svn = seln
    Erase myarray
    i = 1
    For Each crng In rng
     ReDim Preserve myarray(1 To i)
     myarray(i) = crng.Value
     i = i + 1
     Next
    mylim = rng.Count
    myx = 1
    gyou = WorksheetFunction.Combin(rng.Count, seln)
    comb = gyou
    ReDim ans(1 To gyou, 1 To svn)
    ctx = 1
    idx = 1
    End If
  cnt = 0
  Do While myx <= mylim And idx <= gyou
   If cnt > 0 And idx > 1 Then
     For i = 1 To ctx - 1
      ans(idx, i) = ans(idx - 1, i)
      Next
     End If
   ans(idx, ctx) = myarray(myx)
   If ctx + 1 <= svn Then
     Call comb(ans(), , , myx + 1, ctx + 1)
     End If
   myx = myx + 1
   idx = idx + 1
   cnt = cnt + 1
   Loop
  idx = idx - 1
End Function
'削除は、以下のコード
'=======================================================
Sub delete_rng()
  If Not ans_rng Is Nothing Then
    ans_rng.Delete xlUp
    End If
End Sub

【6192】Re:複数の数値の合計が指定した数になるよ...
お礼  よしこ  - 03/6/18(水) 21:52 -

引用なし
パスワード
   ▼LC さん:
▼ichinose さん:

こんばんは。

この度は本当にありがとうございました。
マクロの記録に頼っていた私にとっては・・・
LC さん、ichinose さんのようなすばらしいマクロを
作れるようスキルアップ(お給料もアップ)したいと
思います。

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