| |
▼hideo さん：
こんにちは。
>>>A3,B3には
>>>
>>>A3=9(A1+C1)
↑これ、9*(x+y) ではなく、単純な足し算の答えと内訳だったのですね
これは、わかりましたが・・・。
まだ、不明な点があるのですが・・・（本当は、例を2，3件記述していただきたかったんです）。
後述するｺｰﾄﾞは､
例1、
セルA1〜E1にそれぞれ 5,3,4,6,1という値が入っていた場合、
結果として、
セルA3に 9 セルB3に 10
セルA4に =sum($A$1,$C$1) セルB4に =sum($B$1,$D$1:$E$1)
という結果を表示します。
例2
セルA1〜E1にそれぞれ 20,3,4,6,1という値が入っていた場合、
結果として、
セルA3に 20 セルB3に 14
セルA4に =sum($A$1) セルB4に =sum($B$1:$E$1)
という結果を表示します（こういうパーターンも有りということがはっきりと
確信が持てなかったのですが、見きり発車です）。
では、ｺｰﾄﾞです。
標準モジュール（Module1）に、
'===========================================================
Sub main()
Dim 組合せセル範囲 As Range
Dim 抜き取り数 As Long
Dim セル範囲1 As Range
Dim セル範囲2 As Range
Dim 回答1, 回答2, 式1, 式2
Dim first_flg As Boolean
Set 組合せセル範囲 = Range("a1:e1") 'ここの範囲は、可変にして有ります
first_flg = True
For 抜き取り数 = 1 To (組合せセル範囲.Count \ 2)
Call comb_init(組合せセル範囲, 抜き取り数, 2)
Do While separate_rng(組合せセル範囲, セル範囲1, 抜き取り数, セル範囲2) = 0
If first_flg = True Then
式1 = "=sum(" & セル範囲1.Address & ")"
式2 = "=sum(" & セル範囲2.Address & ")"
回答1 = WorksheetFunction.Sum(セル範囲1)
回答2 = WorksheetFunction.Sum(セル範囲2)
first_flg = False
Else
If Abs(回答2 - 回答1) > Abs(WorksheetFunction.Sum(セル範囲2) - WorksheetFunction.Sum(セル範囲1)) Then
式1 = "=sum(" & セル範囲1.Address & ")"
式2 = "=sum(" & セル範囲2.Address & ")"
回答1 = WorksheetFunction.Sum(セル範囲1)
回答2 = WorksheetFunction.Sum(セル範囲2)
End If
End If
Loop
Next
Range("a3").Value = 回答1
Range("a4").Value = "'" & 式1
Range("b3").Value = 回答2
Range("b4").Value = "'" & 式2
End Sub
'===================================================================
Function separate_rng(origin_rng As Range, rng1 As Range, rng1_cnt As Long, rng2 As Range) As Long
'組合せメンバーと非メンバーの二つのセル範囲を取得する
'input : origin_rng 組合せ対象セル範囲
' : rng1_cnt rng1に入れるセルの数
'output : rng1 ,rng2 : 分けられたセル範囲
' separate_rng : 0-正常に取得 1-データの終わり
ReDim ans(1 To rng1_cnt)
separate_rng = 1
If get_comb(ans()) = 0 Then
Set rng1 = Range(Join(ans(), ","))
Set rng2 = Nothing
For Each crng In origin_rng
If Application.Intersect(crng, rng1) Is Nothing Then
If rng2 Is Nothing Then
Set rng2 = crng
Else
Set rng2 = Union(rng2, crng)
End If
End If
Next crng
separate_rng = 0
End If
End Function
次に標準モジュール（Module2）に
'===================================================================
Private c_svn As Long
Private c_myarray()
Private c_idx() As Long
Private cs_x() As Long
Function comb_init(rng As Range, seln As Long, Optional val_typ As Long = 1) As Double
'組合せ処理の初期化
'input : rng : 組合せを行うセル範囲
' seln: 抜き取り数
' val_type: セル範囲rngのどのプロパティを組み合わせ対象とするかのフラグ
' 1 - value 2- address 3-text
'outptu: comb_init --- 組合せ数
c_svn = seln
Erase c_myarray
Erase c_idx
Erase cs_x()
i = 1
For Each crng In rng
ReDim Preserve c_myarray(1 To i)
c_myarray(i) = Choose(val_typ, crng.Value, crng.Address, crng.Text)
i = i + 1
Next
ReDim cs_x(1 To seln)
ReDim c_idx(1 To seln)
For i = 1 To UBound(c_idx())
cs_x(i) = i
c_idx(i) = i
Next
c_idx(UBound(c_idx())) = c_idx(UBound(c_idx())) - 1
comb_init = WorksheetFunction.Combin(rng.Count, seln)
End Function
'===================================================================
Function get_comb(ans()) As Long
'組合せメンバを配列に取得する
'output : ans() : 組合せメンバー（引数は、1から始まる）
' get_comb : 0-正常に取得 1-データの終わり
get_comb = 1
For i = UBound(c_idx()) To LBound(c_idx()) Step -1
If c_idx(i) + 1 <= UBound(c_myarray()) - c_svn + i Then
c_idx(i) = c_idx(i) + 1
get_comb = 0
Exit For
Else
c_idx(i) = cs_x(i) + 1
cs_x(i) = cs_x(i) + 1
For j = i + 1 To UBound(cs_x())
cs_x(j) = cs_x(j - 1) + 1
c_idx(j) = cs_x(j)
Next j
End If
Next
If get_comb = 0 Then
For i = LBound(c_idx()) To UBound(c_idx())
ans(i) = c_myarray(c_idx(i))
Next
End If
End Function
ｺｰﾄﾞは、以上です。
これで、アクティブシートのセルA1〜E1に値を設定して
プロシジャーmainを実行してみて下さい。
|
|
ichinose
- 04/7/23(金) 13:19 -
