エクセルVBAの自動計算について

質問

エクセルVBAの自動計算について
vbaの自動計算について教えてください。

D　　　　　　E　　　　　　　　F　　　　　　　　I
数量　　　仕様　　　　　　　容積　　　　　　金額
　１　　　仕様1　　　　　　2.50　　　　　　ＸＸＸ

上記の表があります。
Eの仕様は3種類あり、別シートに以下のレート表があってそこから範囲内の容積にある単価を算出します。
その単価にF容積とD数量を掛けたものをI金額に表示して、次行に行き同じことを繰り返します。

レート表は以下の通りです。

　　　H　　　　　　I　　　　　　　J　　　　　　L
6 以上　　　　未満　　　　　仕様1 仕様2
7　　0.01　　　0.80　　　　　3000　　　　　　3500
　　　　　　　　　 中略
13　　5.01　　　6.00　　　　10000　　　　　　12000

よろしくお願い申し上げます。

回答No.10

Wendy02 · ベストアンサー

'---前からの続き---
Private Function mLookUp(ByVal Capa As Double, ByVal Siyo As Variant, Optional u = 0) As Variant
　'単独では使えません!
　Dim Ret As Variant
　Dim rng As Range
　Dim col As Long
　Dim i As Long
　Dim rcol As Range
　If Siyo Like "仕様*" Then
　　Select Case Trim(Siyo)
　　　Case "仕様1": Set rcol = Siyo1: Set rng = BepRng1
　　　Case "仕様2": Set rcol = Siyo2: Set rng = BepRng1
　　　Case "仕様3": Set rcol = Siyo3: Set rng = BepRng1
　　　'------
　　　Case "仕様4": Set rcol = Siyo4: Set rng = BepRng2
　　　Case "仕様5": Set rcol = Siyo5: Set rng = BepRng2
　　End Select
　　col = rcol.Column - rng.Column + 1 + u
　End If
　With rng
　　For i = 1 To .Rows.Count
　　　If .Cells(i, 1).Value <= Capa And .Cells(i, 2).Value > Capa Then
　　　　Ret = .Cells(i, col)
　　　　Exit For
　　　End If
　　Next
　End With
　If IsEmpty(Ret) Then
　　mLookUp = CVErr(xlErrNA)
　Else
　　mLookUp = Ret
　End If
End Function

'なお、一般の関数では、今回の内容は、なかなか難しいのではないかと思います。

お礼

たいへんお手数を取らせて申し訳ございませんでした。
また、何度ものプログラム作成をありがとうございました。
これから確認しますが、ここまでしていただいたので今後は自身で対処していこうと思います。

本当にありがとうございました。
深く感謝いたします。

回答No.9

Wendy02

満足したものができません。時間を伸ばした上に、この程度ですみませんです。今ひとつの段階でとどまってしまっています。構造的には単純な内容ですから、誰にでも読みきれるものだと思います。どうしても自動計算というものを作りたかったのですが、実行型のマクロにとどまっています。もう一度、マクロをご破算にして、考え方からやり直さないと良いものは出来ない感じです。現在のままではイベント型にも向きません。なお、なるべく、ご自身で設定できるように、設定部分はSetteiMacro にまとめられています。

関数の仕様
mLookUp(容量, 仕様, [0か1 入れなければ、0 になる])

'//モジュールの上部から

Dim sh1 As Worksheet '計算シート
Dim Bepyo1 As Worksheet '別表1
Dim Bepyo2 As Worksheet '別表1
Dim rStar As Range
Dim BepRng1 As Range, BepRng2 As Range
Dim Siyo1 As Range, Siyo2 As Range, Siyo3 As Range, Siyo4 As Range, Siyo5 As Range

Sub EnzanMacro()
　 Dim c As Variant
　 Dim ans As Variant
　 Call SettingMacro
　With sh1
　　For Each c In .Range("D2", .Cells(Rows.Count, "D").End(xlUp))
　　If c.Offset(, 2).Value <> "" Then
　　　'容積計算関数
　　　ans = mLookUp(c.Offset(, 2).Value, c.Offset(, 1).Value)
　　　If Val(Replace(c.Offset(, 1).Value, "仕様", "")) < 3 Then
　　　　If Not IsError(ans) Then
　　　　　　c.Offset(, 5).Value = ans * c.Value * c.Offset(, 2).Value　'金額レート×数量×容積
　　　 Else
　　　　 c.Offset(, 5).Value = CVErr(xlErrNA)
　　　 End If
　　 Else
　　　 If Not IsError(ans) Then
　　　　 c.Offset(, 5).Value = ans * c.Value　 '金額レート×数量
　　　 Else
　　　　 c.Offset(, 5).Value = CVErr(xlErrNA)
　　　 End If
　　 End If
　 End If
　　Next
　End With
　Set sh1 = Nothing: Set Bepyo1 = Nothing: Set Bepyo2 = Nothing
End Sub
Private Sub SettingMacro()　'設定用
　'*設定(シート名)
　Set sh1 = Worksheets("Sheet1")
　Set Bepyo1 = Worksheets("Sheet2")
　Set Bepyo2 = Worksheets("Sheet3")
　With sh1
　　'Set rStart = .Range("D2") 'データのラインから(現行では使わない）
　End With
　With Bepyo1
　　Set BepRng1 = .Range("H7", .Cells(Rows.Count, "H").End(xlUp)) 'データのラインから
　　Set Siyo1 = .Range("J7") '仕様1
　　Set Siyo2 = .Range("M7") '仕様2
　　Set Siyo3 = .Range("O7") '仕様3
　End With
　With Bepyo2
　　Set BepRng2 = .Range("C11", .Cells(Rows.Count, "C").End(xlUp)) 'データのラインから
　　Set Siyo4 = .Range("E11") '仕様4
　　Set Siyo5 = .Range("G11") '仕様5
　End With
　'設定終わり
End Sub
'---次に続く---

回答No.8

Wendy02

補足された内容では、もしかしたらと思った通りで、関数の処理では、不可能に近いです。可能なことは可能ですが、重くなりすぎます。もともと、そういう見通しがあって、マクロのご要望だったのかなって思います。意外にややこしいです。

一応、マクロの修正が終わったものの、約2500字あり制限を超えていますので、何度もアップ出来ませんので、最終確認してからアップします。

(1)
買い　　売り
があるようですが、その識別をどのようにしていますか？

修正した関数では、
mLookUp(容量, 仕様, [オプション売り買い]) As Variant
というオプションを設けました。何も入れなければ、2列の左側の選択(買い）を選びます。

(2)
自動計算
にはなっていません。ユーザー定義関数にしたほうがよいのですが、うまく行っていません。理由は、別表のフォームが一定ではないからです。イベントもうまく行っていません。今のところは、通常のマクロのみになっています。自動計算させる場合は、全面的に見直ししないといけません。個人的には、イベントは、演算中にエラーが発生すると、イベントがオフになったままになってしまうので、複雑なものはお勧めできません。

(3)
了解していただきたいのですが、
以上　未満
0.00 　0.80
1.01 　2.00
ということですから、容量で、[0.9] は、エラー表示が出ます。つまり、ここが既存の関数ですと、配列数式になるのですが、別表がいくつもあると、もう既存の関数では無理だと思います。

お礼

何度も本当にありがとうございます。

お問い合わせに関しては、以下のとおりでございます。
（１）ご指摘通り　買い（別表内ではbuyと表示）は左　売り（別表内ではsellと表示）はその右
　　　　に位置しているだけです。

（２）了解しました。
　　　別表を左上につめることは可能ですが、残念ながら容積の範囲が異なるので
　　　２つを合体させることはできません。

（３）数字が飛んでいる部分のエラーも了解しました。

本当にご無理でしたら、結構です。
時間がかかるようでしたら、現在の過去ログの式をコピペする方法で対処いたしますので
ご自身の都合を優先してください。

お礼の言葉ばかりですが、ここまでのご回答に深く感謝いたします。

回答No.7

Wendy02

#6の回答者です。コメント部分が間違っていました。

c.Offset(, 5).Value = ans * c.Value * c.offset(,2).value '金額×単価×容積
　　　　　↓
c.Offset(, 5).Value = ans * c.Value * c.Offset(, 2).Value '容積単価×数量×容積

なお　3.のマクロは、必ずしも、数式とは同じ考え方を持っているわけではありません。複雑な計算方法でもマクロなら可能だということです。

-----
私は、もとの計算自体が理解出来ていないので、次の表現は分かりにくいです。

>仕様３以降は、別のシートで仕様１，２とは違って該当する容積の
>レートがそのまま引っ張る（そのあと数量をかけるのは同じですが）ものなのです。

どのような計算式になるのでしょうか。[レート]というのは、[容積]のことだと思いますが、
そのまま引っ張るとかいう表現が理解していません。

容積単価×数量

ということですか？
--
つまり、[仕様3]--[容量] 0.02--[数量]2
なら、8000 × 2 = 16,000.-
という計算ということです。
--

それから位置関係が、変わったのですか？

補足

いつも、ご回答をありがとうございます。

　　　H　　　　　　I　　　　　　　J　　　　　　L
6 　以上　　　　未満　　　　　仕様1 　　　　　仕様2
7　　0.01　　　0.80　　　　　3000　　　　　　3500
　　　　　　　　　 中略
13　　5.01　　　6.00　　　　10000　　　　　　12000

仕様1および2では、たとえば容積が0.50の場合は
0.50 x 3000（仕様2ならば3500）x 数量　となります

別表の仕様3では、たとえば容積が0.50の場合は
3000（仕様1でたとえたレート）　x 数量　となります

２つの表の位置関係は微妙に変わっています。

言葉足らずで申し訳ございません。

よろしくお願い申し上げます。

回答No.6

Wendy02

8行目が書かれているとよかったですね、きちんとつながっていると思っていますが。
金額×単価×容積？容量で販売するものは、数量は数えないはずですが、そのままにします。

1.関数なら、

=IF(COUNTA(D2:F2)<>3,"",VLOOKUP(F2,Sheet2!$G$7:$L$13,IF(E2="仕様1",3,IF(E2="仕様2",6,8)),TRUE)*D2*F2)

2. 以下のユーザー定義関数を使えます。

こういう関数を入れます。
=IF(COUNTA(D2:F2)<>3,"",myLookUp(Sheet2!$G$7:$L$13,Sheet1!F2,E2)*D2*F2)

3. 純粋にマクロで作れば以下のようになります。
位置関係は、ご質問の通りにしました。
ただし、仕様3 については、現在は仮想の場所になっています。

'//標準モジュール
Function myLookUp(rng As Range, ByVal Data1 As Double, ByVal col As Variant) As Variant
'ユーザー定義関数
　Dim Ret As Variant
　Dim i As Long
　If col Like "仕様*" Then
　　Select Case col
　　　Case "仕様1": col = 3
　　　Case "仕様2": col = 6
　　　Case "仕様3": col = 8 '仮想(要設定）
　　End Select
　End If
　With rng
　　If .Cells(1, 1).Value > Data1 Then '下限
　　　Ret = .Cells(1, col).Value '最下値
　　ElseIf .Cells(rng.Rows.Count, 1).Value <= Data1 Then　'上限
　　　'ElseIf .Cells(rng.Rows.Count, 2).Value <= Data1 Then '繋がっていない場合
　　　Ret = .Cells(rng.Rows.Count, col).Value　'最上値
　　Else
　　　For i = 1 To .Rows.Count
　　　　If .Cells(i, 1).Value <= Data1 And .Cells(i + 1, 1).Value > Data1 Then
　　　　　'繋がっていない場合
　　　　　'If .Cells(i, 1).Value <= Data1 And .Cells(i, 2).Value > Data1 Then
　　　　　Ret = .Cells(i, col)
　　　　　Exit For
　　　　End If
　　　Next
　　End If
　End With
　If IsEmpty(Ret) Then
　　myLookUp = CVErr(xlErrNA)
　Else
　　myLookUp = Ret
　End If
End Function

'//マクロ
Sub TestMacro3()
　Dim sh1 As Worksheet
　Dim sh2 As Worksheet
　Dim rng As Range
　Dim c As Variant
　Dim ans As Variant, col As Long
　Set sh1 = Worksheets("Sheet1")　'シート1　出力場所
　Set sh2 = Worksheets("Sheet2")　'シート2　レート・データ
　'レート範囲
　With sh2
　　Set rng = .Range("G7", .Cells(Rows.Count, "G").End(xlUp).Offset(, 5))
　End With
　'容量計算
　With sh1
　　For Each c In .Range("D2", .Cells(Rows.Count, "D").End(xlUp))
　　　If c.Offset(, 2).Value <> "" Then
　　　　ans = myLookUp(rng, c.Offset(, 2).Value, c.Offset(, 1).Value)
　　　　If Not IsError(ans) Then
　　　　　c.Offset(, 5).Value = ans * c.Value * c.offset(,2).value '金額×単価×容積
　　　　End If
　　　End If
　　Next
　End With
　Set sh1 = Nothing: Set sh2 = Nothing
End Sub

お礼

再びの丁寧なご回答をありがとうございます。

実は、仕様３以降は、別のシートで仕様１，２とは違って該当する容積の
レートがそのまま引っ張る（そのあと数量をかけるのは同じですが）ものなのです。

言葉が足りずに申し訳ございません。

　　　　C　　　　　D　　　　　　E　　　　F　　　　　G　　　　
9　　　　　　　　　　　　　　　仕様3　　仕様4
10　　　以上　　　未満　　　
11　　　0.01　　　0.20 　　 8000　　9000
　　　　　　　　　　中略
20　　　1.81　　　2.00

補足

申し訳ございませんが、補足の補足を書かせていただきます。

最初のシートのL列に売値のセルがありました。（既出は買いでI列）

それで別表１の詳細は以下の通りです。
　　　　H　　　　I　　　　J　　　　K　　　　L　　　　M　　　　N　　　　　O
5　　　　　　　　　　　　　　仕様１、　　　　　仕様２、　　　　　仕様３
6　　以上　　　未満　　　買い　　　売り　　　買い　　　売り　　買い　　　売り
7　0.00　　　0.80
8　1.01　　　2.00
　　　　中略
13　5.01　　　6.00

別表２の詳細は以下の通りです。
　　　　C　　　　D　　　　E　　　　F　　　　G　　　　H　
9　　　　　　　　　　　　　　仕様４、　　　　　仕様５
10　　以上　　　未満　　　買い　　　売り　　　買い　　　売り
11　0.01　　　0.20
12　0.21　　　0.40
　　　　中略
20　1.81　　　2.00

何度も申し訳ございません。
よろしくお願い申し上げます。

回答No.5

imogasi

これはＶＢＡの問題というよりも、ＶＬＯＯＫＵＰ関数（ＴＲＵＥ型）、ＭＡＴＣＨ関数で出来る問題です。
ただＶＢＡでもx=WorsheetFunction.VLOOKUP(Cells(i,"A"),検索表,2,TRUE)
で検索表を引けます。
なぜVBAを使うのですか。即時反応性も関数の方が簡単。
レート表の作り方は
Googleで「エクセル　VLOOKUP関数　True型」で照会すれば、腐るほど実例解説が有るので、勉強のこと。これを知らないレベルでは、VBAを云々は早すぎる。

回答No.4

kagakusuki

関数で充分ではないでしょうか。

　今仮に、自動計算を行うSheetをSheet1、レート表が存在するSheetをSheet2とします。
　まず、Sheet1のI2セルに

=IF(OR(ISNUMBER($D2),ISNUMBER($F2)),IF(AND($D2=INT($D2),COUNTIF(Sheet2!$J$6:$L$6,$E2)>0,$F2>=Sheet2!$H$7),VLOOKUP($F2,Sheet2!$H$7:$L$13,MATCH($E2,Sheet2!$J$6:$L$6,0))*$F2*$D2,""),"")

と入力してから、Sheet1のI2セルをコピーして、同じ列の3行目以下に貼り付けると良いと思います。

お礼

ありがとうございます。

実は他の人の補足に書いたように、仕様のレート表が複数存在するために
現在は仕様をレート表ごとにソートして、関数式をコピペしています。
この作業がなんとか自動化できないかとvbaの活用を質問しました。

回答No.3

tom04

No.1です！
たびたびごめんなさい。

VBAでやるならこんな感じですかね？
尚、前回の画像の配置で仕様の列のデータの行数がいくつでも対応できるようにしてみました。

Sub test()
Dim i, j As Long
j = Cells(Rows.Count, 8).End(xlUp).Row
For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row
Cells(i, 7) = WorksheetFunction.Index(Range(Cells(2, 10), Cells(j, 12)), _
WorksheetFunction.Match(Cells(i, 6), Range(Cells(2, 8), Cells(j, 8)), True), _
WorksheetFunction.Match(Cells(i, 5), Range(Cells(1, 10), Cells(1, 12)), False)) _
* Cells(i, 4) * Cells(i, 6)
Next i
End Sub

何度も失礼しました。m(__)m

お礼

関数、VBAとともに考えてくださってありがとうございます。
助かります。

回答No.2

某HN クロメート(Chromate)（@CoalTar）

数式ならG2セルに
=IF(COUNTA(D2:F2)<>3,"",D2*F2*INDEX($J$7:$K$13,MATCH(F2,$H$7:$H$13),MATCH(E2,$J$6:$K$6,0)))
なのでF列のみでの判定ですが

Sub Macro1()
　　　With Range("G2", Range("F" & Rows.Count).End(xlUp).Offset(, 1))
　　　　　　.FormulaR1C1 = "=RC[-3]*RC[-1]*INDEX(R7C10:R13C11,MATCH(RC[-1],R7C8:R13C8),MATCH(RC[-2],R6C10:R6C11,0))"
　　　　　　.Value = .Value
　　　End With
End Sub

正式？なマクロはわかりません

お礼

ありがとうございました。

図も付けていただけて見やすかったです。

回答No.1

tom04

こんにちは！
VBAでないので参考にならなかったらごめんなさい。

↓の画像のように勝手に表を作ってみました。

G2セルに
=IF(COUNTBLANK(D2:F2),"",INDEX($J$2:$L$7,MATCH(F2,$H$2:$H$7,1),MATCH(E2,$J$1:$L$1,0))*D2*F2)
という数式を入れ、オートフィルで下へコピーすると
画像のような感じになります。

参考にならなかったらごめんなさいね。m(__)m