VBAのSUBPRODUCT関数の引数について

このQ&Aのポイント
  • VBAのSUBPRODUCT関数を使って部品単価×分子員数/分母員数の合計を計算する方法について質問があります。
  • 質問者はマクロ記録をした際のコードでは部品の追加に対応できないため、分子員数の逆数を受け付けないエラーが発生していると述べています。
  • 簡潔かつ効果的な方法でD3セルへ関数としての計算結果を入力する方法についてのアドバイスを求めています。
回答を見る
  • ベストアンサー

VBAのSUBPRODUCT関数の引数について

VBAに詳しい方へ  部品単価積み上げなどで 部品単価×分子員数/分母員数の合計を計算するときにSUBPRODUCT関数を使いますがマクロ記録すると Range("D3").Select ActiveCell.FormulaR1C1 = "=SUMPRODUCT(R5C2:R9C2,1/R5C3:R9C3,R5C4:R9C4)" となります。  2列に員数分子 3列に員数分母、4列に部品単価が 5行から下に部品ごとに記入されています。 D3セルに 関数として入力されます。 これでは 部品の追加に対処できないので セルを変数にして表現したいのです。 これと同じことを VBAで行数可変に対応すると 分母員数の逆数を受け付けず 実行時エラー13:型が一致しない と表示されます。   Option Explicit Dim 分子群 As Range Dim 分母群 As Range Dim 単価群 As Range Sub Macro1() ' Range("D3").Select ActiveCell.FormulaR1C1 = "=SUMPRODUCT(R5C2:R9C2,1/R5C3:R9C3,R5C4:R9C4)" '---(1) 計算可能だが動的に対処不可能 End Sub Sub Macro2() Range("D3").Select Set 分子群 = Range(Cells(5, 2), Cells(Cells(5, 2).End(xlDown).Row, 2)) Set 分母群 = Range(Cells(5, 3), Cells(Cells(5, 3).End(xlDown).Row, 3)) Set 単価群 = Range(Cells(5, 4), Cells(Cells(5, 4).End(xlDown).Row, 4)) ActiveCell = Application.SumProduct(分子群, 分母群, 単価群) '---(2) エラー発生なし ActiveCell = Application.SumProduct(分子群, 1 / 分母群, 単価群) '---(3) エラー発生 (1)と同じ表現(分母)にできない。 End Sub これ以上のセル列は使わず、簡潔にD3セルへ入力するにはどうすればよろしいでしょうか? 結果数値だけでなく、関数が入力されるのが希望です。 基本的知識が乏しく、恐縮ですが よろしくご回答をお待ちしております。------以上

質問者が選んだベストアンサー

  • ベストアンサー
  • tom04
  • ベストアンサー率49% (2537/5117)
回答No.4

またまたお邪魔します。 >実際の計算は 数千行×数千列なので時間がかかりすぎるので・・・ SUMPRODUCT関数そのものが配列数式になりますので、データ量が極端に多い場合 PCにかなりの負担をかけ、結果的にはFor~Nextでループさせた方が早い場合もあります。 そこで一案ですが、ループさせるのではなく、使っていない列(仮にE列だとします)を 作業用の列として各行の計算をし、その合計をD3セルに表示させてみてはどうでしょうか? この場合も計算結果しか表示されませんので、メッセージボックスに計算範囲を表示させてみました。 Sub Sample2() Dim endRow As Long endRow = Cells(Rows.Count, "B").End(xlUp).Row If endRow > 4 Then Range(Cells(5, "E"), Cells(endRow, "E")).Formula = "=B5/C5*D5" Range("D3") = WorksheetFunction.Sum(Range("E:E")) Range("E:E").ClearContents MsgBox "B5セル~D" & endRow & "の計算結果", vbOKOnly End If End Sub ※ おそらくループさせるよりもはやいと思います。 ※ 列も数千列!というコトですがどのような計算方法になるのか判らないので 最初の質問通りの3列のみとしています。m(_ _)m

NYAFRAC
質問者

お礼

tom04様   いただいたスクリプトを拝借して、次のようにしました。  ・1列 増設することはやむなしとして 6列目に分母の逆数を計算し  ・関数はSUBPRODUCTを使って可変行数に 対応できました。 ありがとうございました。勉強になりました。 Option Explicit Dim i As Long Sub macro1() i = Cells(Rows.Count, 2).End(xlUp).Row Range(Cells(5, 6), Cells(i, 6)).FormulaR1C1 = "=1/RC[-3]" Cells(3, 4).FormulaR1C1 = "=SUMPRODUCT(R5C2:R" & i & "C2,R5C6:R" & i & "C6,R5C4:R" & i & "C)" End Sub

NYAFRAC
質問者

補足

tom04様  回答ありがとうございます。 いただいたコードを走らせ、結果が正しいことを確認しました。 1列 ダミーで 必要になるのが気になりますが、 Forループより早そうなので実際のリストで今夜確認します。 Range(Cells(5, "E"), Cells(endRow, "E")).Formula = "=B5/C5*D5" という式は知りませんでした。 右辺が絶対番地での計算式が 5行目以外にも相対的に適用されるのが不思議です。 私は 数千行・列を扱うのでR1C1形式で考えたいのですが このヒントでやってみて、うまくいったらまたご報告いたします。 確かにSUBPRODUCT関数にこだわる必要はないということですね。

その他の回答 (3)

  • tom04
  • ベストアンサー率49% (2537/5117)
回答No.3

続けておじゃまします。 >同様の計算を簡潔には表現できないものでしょうか? の件について・・・ 最終行の取得がネックになっていますね。 特に関数で行う場合は前回の数式のような感じで行うしかないと思います。 これらを考慮すると今回の場合は数式の表示はあきらめて、結果だけをVBAで表示するのが一番簡単だと思います。 一例としては Sub Sample1() Dim i As Long, endRow As Long, vL As Variant endRow = Cells(Rows.Count, "B").End(xlUp).Row If endRow > 4 Then For i = 5 To endRow vL = vL + Cells(i, "B") / Cells(i, "C") * Cells(i, "D") Next i Range("D3") = vL End If End Sub こんな感じでしょうかね! ※ 実はVBAでSUMPRODUCT関数が使用できないか↓のようなコードも考えてみました。 Dim i As Long i = Cells(Rows.Count, "B").End(xlUp).Row If i > 4 Then Range("D3") = WorksheetFunction.SumProduct(Range("B5:B" & i) / Range("C5:C" & i) * Range("D5:D" & i)) End If これを実行してみると「型が一致しません」となり色々試行錯誤してもダメだったので 結局あきらめました。m(_ _)m

NYAFRAC
質問者

補足

tom04様  色々考えて実行までして、いただいてありがとうございます。 前半部分のお答えのように  Forループで 変数をVBA側で持って計算させるのはできますが 実際の計算は 数千行×数千列なので時間がかかりすぎるので回避したいところです。 様々な時間がかかっている集計の内の一部を取り出して質問しているので 時間短縮が必要です。 また 数値結果だけだと、後から見る人が検証できないというのが嫌らしいところです。 間違えていても発見できない。   後半部分がまさにやりたいことです。 ワークシートのSUMPRODUCTでは 引数に (範囲1,1/範囲2、範囲3)とできるのに VBAでこの関数を呼び出すと できないのが本当にそうなのか、なにか私の使い方が違うのか もう少し どなたかのご指摘をお待ちします。  

  • tom04
  • ベストアンサー率49% (2537/5117)
回答No.2

No.1です! >セルを変数にして表現したいのです を見逃していました。 結局今後データが増えた場合は最終行を取得し、そのセル番地そのものを数式に入れ表示したい! というコトですよね? 色々やってみましたが仮に最終行が20行目の場合 >=SUMPRODUCT(B5:B20/C5:C20*D5:D20) といった数式がD3セル入り、その計算結果が表示されるのがご希望のようですが 結構難しいように思えます。 関数で行うにしてもD3セルに =SUMPRODUCT(INDIRECT("B5:B"&MAX(IF(B1:B1000<>"",ROW(A1:A1000))))/INDIRECT("C5:C"&MAX(IF(B1:B1000<>"",ROW(A1:A1000))))*INDIRECT("D5:D"&MAX(IF(B1:B1000<>"",ROW(A1:A1000))))) (上記数式は配列数式となりますので、Shift+Ctrl+Enterで確定する必要があります。) といった感じの数式になってしまいますので、お望み通りの数式にはならないですねぇ~~! 一番簡単なのは、VBAで5行目~最終行までの各行の計算をコツコツプラスしていく方法ではないでしょうか? (この場合は計算結果しか表示されませんが・・・) この程度でごめんなさいね。m(_ _)m

  • tom04
  • ベストアンサー率49% (2537/5117)
回答No.1

こんばんは! 結局B5~D9セルの範囲で B列÷C列×D列 の各行の結果を 5~9行まで合計すればよい訳ですよね? それでよいのであればごく単純に Range("D3").Formula = "=SUMPRODUCT(B5:B9/C5:C9*D5:D9)" だけで良いと思うのですが・・・m(_ _)m

NYAFRAC
質問者

お礼

tom04様 行き違いで No2.の回答いただきました。  ありがとうございます。 INDIRECT関数については 存じませんでした。勉強してみます。 同様の計算を簡潔には表現できないものでしょうか?

NYAFRAC
質問者

補足

tom04様 早速の回答ありがとうございます。 ActiveCell.FormulaR1C1 = "=SUMPRODUCT(R5C2:R9C2,1/R5C3:R9C3,R5C4:R9C4)"は Range("D3").Formula = "=SUMPRODUCT(B5:B9/C5:C9*D5:D9)"ともかけるのですね。  ただ質問の趣旨は 9行目までに制約されないで 任意の入力最後尾行まで 【つまり.end(xldown)】 の計算についてなので 違う回答をお願します。 ActiveCell = Application.SumProduct(分子群, 1/分母群, 単価群) も ActiveCell = Application.SumProduct(分子群 / 分母群 * 単価群) と書けるのかと 思って実行してみましたが、エラー発生し、通りませんでした。

関連するQ&A

  • 関数の中で参照するセル範囲(変動する)の記述方法

    セルJ5に下記の数式を入力するマクロを組みたいのですが、記述方法が分かりません。   =SUMIF(セル範囲(1),B5,セル範囲(2))  ・セル範囲(1)にはB5:C列の最終データまで  ・セル範囲(2)にはC5:C列の最終データまで 自分なりに   ActiveCell.Formula = "=SUMIF(Range(Cells(5, 2), Cells(Range("b5").End(xlDown).Row, 3)),b5,Range(Cells(5, 2), Cells(Range("C5").End(xlDown).Row, 3)))" と書いてみたのですがダメでした。 どうかご教授お願い致します。

  • Excel VBAについて

    以下のコードをFor Nextでまわすには どうしたらよいでしょうか? Sub sample() Range("A2").Select ActiveCell.FormulaR1C1 = "=テスト!R[1]C" Range("A3").Select ActiveCell.FormulaR1C1 = "=テスト!R[3]C" Range("A4").Select ActiveCell.FormulaR1C1 = "=テスト!R[5]C" Range("A5").Select ActiveCell.FormulaR1C1 = "=テスト!R[7]C" Range("A6").Select ActiveCell.FormulaR1C1 = "=テスト!R[9]C" Range("A7").Select ActiveCell.FormulaR1C1 = "=テスト!R[11]C" End Sub

  • vba  

    VBAはじめたばかりで、躓きました。 下記を実行すると、”Nextに対するForがありません。”とでます。 なぜこうなるのか教えてください。  G2~列2000の間が空白になるまで、  下記の処理を続けるようにしたいと思っています。  Dim i As Integer For i = 7 To 2000 Do If Cells(2, i) = "" Then Range("G2").End(xlToRight).Select ActiveCell.CurrentRegion.Resize(6, 5).Select Selection.Cut Range("B2").End(xlDown).Select ActiveCell.Offset(1).Select ActiveSheet.Paste Exit Do End If Next i Loop  よろしくお願いします。

  • エクセルVBAの保存

    毎月異なった新しいエクセルファイルに同じような加工を施すため、VBAを書きました。対象はActivesheetとしています。 で、質問は、この新しいエクセルファイルの標準モジュールにいちいちこのVBAをコピーペーストせずに実行する方法です。 きっと何かあるとは思うのですが・・・・。 VBAは次のような簡単なものです。 Sub 加工1() Dim e As Integer, s As String, n As String e = Range("A4").End(xlDown).Row s = Replace(Mid(Range("A2"), 8, 5), "年", "") & "-" n = Replace(Mid(Range("A2"), 19, 5), "年", "") & "-" Range("A1:C2").MergeCells = False Columns("B:B").Select Selection.Insert Shift:=xlToRight Columns("A:A").Select Selection.Insert Shift:=xlToRight Columns("C:C").Select Selection.NumberFormatLocal = "G/標準" Range("B3").Select Selection.AutoFill Destination:=Range("B3:C3"), Type:=xlFillDefault Range("B3").Select ActiveCell.FormulaR1C1 = "商品番号1" Range("C4").Select ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],10)" Range("C4").Select Selection.AutoFill Destination:=Range("C4:C" & e), Type:=xlFillDefault Range("A3").Select ActiveCell.FormulaR1C1 = "抽出年月日" Range("A4").Select ActiveCell.FormulaR1C1 = s & n & 1 Range("A4").Select Selection.AutoFill Destination:=Range("A4:A" & e), Type:=xlFillDefault Rows("3:3").Select Selection.Insert Shift:=xlDown Range("B1:E1").MergeCells = True Range("B2:E2").MergeCells = True ActiveSheet.Name = "提出用" End Sub

  • VBAでエラーになってしまう

    初心者です。 RangeクラスのSelectメゾットが失敗しました。となります。 このコードは、マクロの記録を行い、そのコードをコマンドボタンのコードにコピーしたものです。 初心者なので、マクロの記録からやりました。 どうか、わかる方がいらっしゃいましたら、教えてください。 Private Sub CommandButton4_Click() Sheets("印刷ページ").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("C6").Select ←ここが黄色くなり、エラーになります。 ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("D6").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("E6").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("B8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("C8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("D8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("E8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("F8").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("B10").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("C10").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("D10").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" Range("E10").Select ActiveCell.FormulaR1C1 = "='鈴木 一郎'!R[2]C" End Sub

  • フィルタでくくった状態でコピー貼り付け (2)

    以前に、http://okwave.jp/qa/q6456460.html で質問して解決したのですが 別のパターンで質問です。 以前は、L2から絶対だったのですが、今回は、セルが決まってません。 Lの1404にセルを持ってくるのに 一応 Sub 仕入先ブランク解除() Range("L1").Select Selection.End(xlDown).Select Selection.AutoFilter Field:=12, Criteria1:="=", Operator:=xlAnd Call 下に移動 ActiveCell.FormulaR1C1 = "=RC[-9]" Call 右に1マス移動 ActiveCell.FormulaR1C1 = "=RC[-9]" End Sub Sub 下に移動() ro = ActiveCell.Row co = ActiveCell.Column Range(Cells(ro + 1, co), Cells(ro + 1, co)).Select End Sub Sub 右に移動() ro = ActiveCell.Row co = ActiveCell.Column Range(Cells(ro + 1, co), Cells(ro + 1, co)).Select End Sub Sub 右に1マス移動() i = ActiveCell.Row j = ActiveCell.Column Cells(i + 0, j + 1).Select End Sub Sub メーカー名コピーあんど貼付() Dim r As Range With ActiveSheet Set r = .Range("L2", .Cells(.Rows.Count, "K").End(xlUp).Offset(, 1)) r.Item(1).Copy r If .FilterMode Then .ShowAllData End If r.Value = r.Value End With Set r = Nothing End Sub ってしました。 その後、関数のコピー貼り付けができません。(メーカー名コピーあんど貼付)の部分です わかる方がいましたらお願いします。

  • Excel2013>VBA>sendkeys動ず

    Excel2013のVBAを使って自動更新をしようと思っています。    A  B   C 1  あ  AA  0 2  い  AB  1 3  う  AC  0 4  え  AA  1 5  お  AA  0 上記のようにシート内にデータはあります。B列「AA」C列の「ゼロ」を更新してC列の値を「1」にしようとしたときに、ピボットテーブルを使ってみようと思いました。 ピボットテーブルにてB列の「AA」、C列の「ゼロ」を抽出表示しました。   A  B  C 1 あ  AA  0 5 お  AA  0 思っていたように1行目と5行目が抽出されました。 後はゼロを別の値(仮に「2」とします)に変更するときに、カーソルの移動がうまくいきませんでした。 Range("C1").End(xlDown).Select Do ActiveCell.Offset(0, 0) = "2" ActiveCell.Offset(-1, 0).Select If Len(ActiveCell.Offset(0, 0)) = 0 Then Exit Do End If Loop しかし、これではカーソルが「C4」に移動してしまいました。 ピボットテーブルでたたんでしまっても、カーソルは見えないセルに移動するようです。 そこで、下記のように変更しました。 Range("C1").End(xlDown).Select Do ActiveCell.Offset(0, 0) = "2" Application.SendKeys "{UP}" If Len(ActiveCell.Offset(0, 0)) = 0 Then Exit Do End If Loop これは、カーソルがまったく動かずに最初の地点にいたままでした。 そこで、次はTABで移動することにしました。 Range("C1").Select Selection.SpecialCells(xlCellTypeVisible).Select Do ActiveCell.Offset(0, 0) = "2" Application.SendKeys "{tab}" If Len(ActiveCell.Offset(0, 0)) = 0 Then Exit Do End If Loop これでもカーソルは動きませんでした。 どうにかしてsendkeysの動かし方、もしくは更新でもっとうまいやり方をご存知の方、是非教えてください。よろしくお願いいたします。

  • エクセルVBAが書ける方へ

    お世話になります。 下記VBAはB19からB28までのデータをA11:12の横列に貼り付けさせる内容です。 Sub 特価() ' ' 特価 Macro ' ' Range("A11:A12").Select ActiveCell.FormulaR1C1 = "=R[8]C[1]" Range("B11:B12").Select ActiveCell.FormulaR1C1 = "=R[9]C" Range("C11:C12").Select ActiveCell.FormulaR1C1 = "=R[10]C[-1]" Range("F11:F12").Select ActiveCell.FormulaR1C1 = "=R[11]C[-4]" Range("H11:I12").Select ActiveCell.FormulaR1C1 = "=R[12]C[-6]" Range("T11:U12").Select ActiveCell.FormulaR1C1 = "=R[13]C[-18]" Range("X11:Y12").Select ActiveCell.FormulaR1C1 = "=R[14]C[-22]" Range("AD11:AE12").Select ActiveCell.FormulaR1C1 = "=R[15]C[-28]" Range("AN11:AO12").Select ActiveCell.FormulaR1C1 = "=R[16]C[-38]" Range("AW11").Select ActiveCell.FormulaR1C1 = "=R[17]C[-47]" Range("B23").Select End Sub これに下記内容を追加したいのですが教えて下さい。 ・B19からB28のデータは入力後消す。 ・貼り付けたら次に入力する時は下の行(A13:14)に貼り付ける。 ・同様にデータを消してA15:16に貼り付ける。以下、下の行に貼り付けていくようにする。 ・貼り付けたらカーソルはB19を選択した状態にする。 言葉足らずでしたら補足します。 何卒宜しくお願い致します。

  • VBAでIF文を作成したが、もう少しまとめたい。

    以下のようなVBAを作成しました。 動作に問題はないのですが、 もっと簡単にまとめることができる気がしますが、うまくできません。 何かやりかたはあるのでしょうか。 宜しくお願い致します。 If Cells(5, 1).Value = Cells(1, 1).Value Then Cells(100, 100).Select ActiveCell.FormulaR1C1 = Cells(5, 1) End If If Cells(6, 1).Value = Cells(1, 1).Value Then Cells(100, 100).Select ActiveCell.FormulaR1C1 = Cells(6, 1) End If If Cells(7, 1).Value = Cells(1, 1).Value Then Cells(100, 100).Select ActiveCell.FormulaR1C1 = Cells(7, 1) End If If Cells(8, 1).Value = Cells(1, 1).Value Then Cells(100, 100).Select ActiveCell.FormulaR1C1 = Cells(8, 1) End If If Cells(9, 1).Value = Cells(1, 1).Value Then Cells(100, 100).Select ActiveCell.FormulaR1C1 = Cells(9, 1) End If If Cells(10, 1).Value = Cells(1, 1).Value Then Cells(100, 100).Select ActiveCell.FormulaR1C1 = Cells(10, 1) End If

  • Excel VBA 計算範囲の変更について教えてください。

    こんばんは。とても困っています。 下記のような表で=A1&B1&C1の計算式を入れ、A1とB1を絶対参照にして$A$1&$B$1&C1としてD3までオートフィルをかけます。 そしてD4は =$A$4&$B$4&C4のように絶対参照しているセルを変更したいのです。たくさんありすぎて参照する範囲を変更するのにとても大変な思いをしています。VBAでどのようにすればよいのか教えてください。   |A    B   C     D ------------------------------------- 1| 1T  11L   A    1T11LA (=$A$1&$B$1&C1) 2|          B    1T11LB (=$A$1&$B$1&C2) 3|          C    1T11LC (=$A$1&$B$1&C3) 4| 2T  20L   A    2T20LA (=$A$4&$B$4&C4) 5|          B     2T20LB (=$A$4&$B$4&C5) 6|          C    2T20LC (=$A$4&$B$4&C6) 7| 3T  31M   A    3T31MA (=$A$7&$B$7&C7) 8|          B     3T31MB (=$A$7&$B$7&C8) マクロで記録させたらところ下記のようになりました。 Sub 4行置きに参照範囲を変更する() Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "=RC[-3]&RC[-2]&RC[-1]" Range("D1").Select ActiveCell.FormulaR1C1 = "=R1C1&R1C2&RC[-1]" Range("D1").Select Selection.AutoFill Destination:=Range("D1:D3"), Type:=xlFillDefault Range("D1:D3").Select Range("D4").Select ActiveCell.FormulaR1C1 = "=R4C1&R4C2&RC[-1]" Range("D4").Select Selection.AutoFill Destination:=Range("D4:D6"), Type:=xlFillDefault Range("D4:D6").Select Range("D7").Select ActiveCell.FormulaR1C1 = "=R7C1&R7C2&RC[-1]" Range("D7").Select Selection.AutoFill Destination:=Range("D7:D9"), Type:=xlFillDefault Range("D7:D9").Select End Sub ◎初心者なのでVBAにたくさんコメントを入れていただくと助かります。 宜しくお願い致します。

専門家に質問してみよう