| |
▼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
|
|
