Excel VBA質問箱 IV

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

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


65022 / 76733 ←次へ | 前へ→

【16288】Re:平均値の参照
回答  ichinose  - 04/7/23(金) 13:19 -

引用なし
パスワード
   ▼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を実行してみて下さい。

2 hits

【16249】平均値の参照 hideo 04/7/22(木) 10:36 質問
【16251】Re:平均値の参照 ichinose 04/7/22(木) 10:52 発言
【16252】Re:平均値の参照 hideo 04/7/22(木) 11:12 お礼
【16273】Re:平均値の参照 ichinose 04/7/22(木) 21:32 発言
【16286】Re:平均値の参照 hideo 04/7/23(金) 12:09 発言
【16288】Re:平均値の参照 ichinose 04/7/23(金) 13:19 回答
【16304】Re:平均値の参照 hideo 04/7/23(金) 17:05 お礼

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