Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

75005 / 76738

←次へ　｜　前へ→


	【6182】Re:複数の数値の合計が指定した数になるよ...

ichinose - 03/6/18(水) 12:45 -


	引用なし

	パスワード

▼LC さん：
▼よしこさん：
こんにちは。
前に組み合わせのご質問があったときに作ったコードをそのまま使いました。
「Ａ列の組み合わせ合計がセルＣ１と同じになった値を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

0 hits

▼

【6113】複数の数値の合計が指定した数になるようにしたいのですが・・・ よしこ 03/6/16(月) 22:03