Excel ＶＢＡ 「小計」と入力したら自動計算

エクセルの小計の計算について質問いたします。

　　　Ａ列　　　　Ｂ列　　　　　　Ｃ列　　　Ｄ列　　　　　Ｅ列　　　　Ｆ列

１　施設名　
２　　　　　　商品名,内容　　　１　　　　単位　　　　　単価　　　　金額（数量×単価）
３　　　　　　商品名,内容　　　１　　　　単位　　　　　単価　　　　金額（数量×単価）
４　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　小計　　　　　●●●●
―――――――――――――――――――――――――――――――――
５　施設名
６　　　　　　商品名,内容　　　１　　　　単位　　　　　単価　　　　金額（数量×単価）
７　　　　　　商品名,内容　　　１　　　　単位　　　　　単価　　　　金額（数量×単価）
８　　　　　　商品名,内容　　　１　　　　単位　　　　　単価　　　　金額（数量×単価）
９　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　小計　　　　　●●●●
―――――――――――――――――――――――――――――――――
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　合計　　　　　●●●●

施設名ごとに項目が複数あり、施設ごとに項目の数も違います。
これを施設ごとに●の所に小計を出したいです。

「小計」が数回にわたり出てくる場合は、「前回小計をした次のセルから今回小計するセルの前まで」を計算させる訳ですが、どんなＶＢＡを組めばいいのかわかりません。

理想としてはにＥ列に小計という文字を入れるとＦ列に自動で計が出るようにして、さらに小計の合計を最後の行のセルにだしたいです。。
さらに、見やすくなるように小計の下のセルにＡ～Ｆの間に太線を引いて施設ごとの区切りがわかるようにしたいです。。

繰り返し作業ばかりで大変です。

どなたか知恵をお貸しください。

No.10 ベストアンサー 回答者： tom04 回答日時： 2013/04/02 16:29

続けてお邪魔します。

No.9の補足を読みました。
この際ですので、とことん付き合っちゃいます！
今までのコードはすべて無視してください。

結局、↓の画像でB・E（A列も含めて）変更があるたびにマクロを実行しなければならなくて、
なおかつ小計・合計の行に関しては数式で表示！
がご希望だというコトですので、もう一度考えてみました。

合計の場合は単にSUMIF関数で対応できますが、小計の行は数式でやる場合
配列数式を使う必要があると思います。
VBAで配列数式はおそらく拒否されると思います。
そこで一案です。
↓の画像のように作業用の列を2列設けます。
G1セルに
=IF(E2="小計",SUM(INDIRECT("F"&LARGE($H$1:$H1,2)&":F"&MAX($H$1:$H1))))
H1セルに
=IF(COUNTA(A2:E2),IF(E2="",ROW()+2,IF(OR(E2="",E2="小計"),ROW(),"")))
という数式を入れG1・H1セルを範囲指定　→　H1セルのフィルハンドルでずぃ～～～！っと
これ以上データはないというくらい「これでもか！」っとオートフィルでコピーしておきます。
作業列が目障りであれば、オートフィル後にG・H列を非表示にしておきます。
そうした操作を行った上で、↓のコードをコピー＆ペーストしてデータを入力してみてください。
データ配置は画像通りとします。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim i As Long
If Application.Intersect(Target, Range("A:A,C:C,E:E")) Is Nothing Or Target.Count <> 1 Then Exit Sub

With Target
i = .Row
If .Column = 1 Then
Range(Cells(i, "E"), Cells(i, "F")).ClearContents
ElseIf .Column = 3 Or .Column = 5 Then
If IsNumeric(.Value) Then
Cells(i, "F") = Cells(i, "C") * Cells(i, "E")
Else
If IsNumeric(.Value) Then
.Offset(, 1) = .Offset(, -2) * Target
ElseIf .Value = "小計" Then
.Offset(, 1).ClearContents 'この行を追加
.Offset(, 1).Formula = .Offset(-1, 2).Formula '←G列の数式をそのまま引用
With Cells(i, 1).Resize(1, 6).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
ElseIf .Value = "合計" Then
.Offset(, 1).Formula = "=SUMIF(E:E,""小計"",F:F)"
End If
End If
End If
End With
End Sub 'この行まで

この程度しか思いつきません。
お役に立ちますかね？m（_ _）m

この回答への補足

(T0T)ありがとうございます！！！
何回も何回も要望を聞いていただいてありがとうございます！！

先ほど新しいＶＢＡを入れてみました（*＾＾*）
確かに！！
こんな方法があるんですね！！！

でも、なぜか小計の金額がどうしても合わないのです。。。
小計の金額がなぜかよくわからない合計になってしまうのです。。

なぜでしょうか。。。。

それと一つ聞きたいのですが、小計の出し方を、前のように数字で出すようにしたとして、もしその後に項目が変わり数量や単価の金額を訂正するようになった場合、自動的に小計の金額も変わるようにはできたりはしませんか？？？

ほんとに申し訳ありません。。。

御礼もしたいです。

超初心者ですみません。

補足日時：2013/04/02 18:09

この回答へのお礼

何回も質問に答えてくれてありがとうございました。
何もわからないところから、何とか糸口が見えてきたのはかなりの進歩だと思います。

引き続きいろいろと対策を練っていきたいと思います。

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

また何かの時は宜しくお願いいたします。

お礼日時：2013/04/03 13:33

No.9 回答者： tom04 回答日時： 2013/04/01 21:07

No.2・8です。

何度もごめんなさい。
前回のコードで不具合がありました。

↓のコードに変更してください。（配置は画像通りとします）

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim i As Long, k As Long
If Application.Intersect(Target, Range("A:A,E:E")) Is Nothing Or Target.Count <> 1 Then Exit Sub

With Target
i = .Row
If .Column = 1 Then
Range(Cells(i, "E"), Cells(i, "F")).ClearContents
Else
If IsNumeric(.Value) Then
.Offset(, 1) = .Offset(, -2) * Target
ElseIf .Value = "小計" Then
k = i - 1
Do While Cells(k, "E") <> "" '←ココを修正
k = k - 1
Loop
.Offset(, 1) = WorksheetFunction.Sum(Range(Cells(k, "F"), Cells(i, "F")))
With Cells(i, 1).Resize(1, 6).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
ElseIf .Value = "合計" Then
.Offset(, 1) = WorksheetFunction.SumIf(Range(Cells(2, "E"), Cells(i, "E")), "小計", _
Range(Cells(2, "F"), Cells(i, "F")))
End If
End If
End With
End Sub 'この行まで

※　検証せずに投稿してごめんなさいね。m(_ _)m

この回答への補足

おはようございます。
何度も検証していただき、ご投稿ありがとうございました。
まさに、小計と入れた時に数字が出てきました。
ありがとうございます。

厚かましくも、またまたお願いなんですが、

＞Ｆ列の単価の行に数字を入れると自動的にＧ列の金額の所に（数量Ｄ列×単価Ｆ列）が入るようにできますでしょうか？？？
↑この時や
小計、合計を入力するときなんですが、数字ではなくて計算式を入れて計算できますか？
例えば
tom04さんが明記してくれた画像の、
〇〇施設の小計を出すときにＦ６に合計した数字ではなくて
=SUM(F3:F5)を入れて数字を出したいです。
なぜかというと単価や数量が見積作成段階で何回か訂正されることがあるんです。。

あと、小計なんですが、〇〇施設（一番初めの小計）は問題なく計が出るのですが、△△施設（一番目以降の小計）は、〇〇施設の個別の金額+〇〇施設の小計の金額も足された金額がでてしまいます。

これはどのように解決すればよろしいでしょうか？？？


何回も何回もごめんなさい。

補足日時：2013/04/02 11:12

No.8 回答者： tom04 回答日時： 2013/04/01 20:26

No.2です。

補足に
＞合計はその都度でる感じではなくて合計と入れると、今までの小計が合計されて出るようにできますか？？

＞Ｆ列の単価の行に数字を入れると自動的にＧ列の金額の所に（数量Ｄ列×単価Ｆ列）が入るようにできますでしょうか？？？

と2点の件がありましたので・・・

最初の質問文と補足の列が違っているようなので、↓の画像の配置だとしてのコードです。
（1行目の配置が少し違うかと思いますが、普通は1行目が項目行になると思いますので、敢えて↓のような配置にしています。

前回のコードは無視して↓のコードに変更してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim i As Long, k As Long, c As Range
If Application.Intersect(Target, Range("A:A,E:E")) Is Nothing Or Target.Count <> 1 Then Exit Sub

With Target
i = .Row
If .Column = 1 Then
Range(Cells(i, "E"), Cells(i, "F")).ClearContents
Else
If IsNumeric(.Value) Then
.Offset(, 1) = .Offset(, -2) * Target
ElseIf .Value = "小計" Then
k = i - 1
Do While IsNumeric(Cells(k, "E"))
k = k - 1
Loop
.Offset(, 1) = WorksheetFunction.Sum(Range(Cells(k, "F"), Cells(i, "F")))
With Cells(i, 1).Resize(1, 6).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
ElseIf .Value = "合計" Then
.Offset(, 1) = WorksheetFunction.SumIf(Range(Cells(2, "E"), Cells(i, "E")), "小計", _
Range(Cells(2, "F"), Cells(i, "F")))
End If
End If
End With
End Sub 'この行まで

※　余計なお世話かもしれませんが、A列に「施設名」を入力すると、その行の「合計」と「合計金額」は
消すようにしてみました。
※　今回もデータは画像でいえば2行目から入力するとしています。

こんな感じではどうでしょうか？m(_ _)m

No.7 回答者： JazzCorp 回答日時： 2013/03/30 08:57

'データシートをアクティブにして実行する

'データは明細だけで合計行は自動作成（事前の加工は無用！）
'別データシートに編集更新版（何回でもやり直し可能）
'環境依存部分はConstを変更する
Option Explicit
Sub Breaks()
Const xName_To = "Summary"
Const xKey_Col = 1
Const xSum_Col = 6
Const xHeads = 1
Const xSepa = "="
Dim xSheet As Worksheet
Dim xName_From As String
Dim xBorder As String
Dim xSum As Long
Dim xSum_Small As Long
Dim xChk_Row As Long
Dim xLast_From As Long
Dim xLast_To As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long
Dim xNoData As Boolean
Application.ScreenUpdating = False
xName_From = ActiveSheet.Name
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(xName_To).Delete
xNoData = True
For Each xSheet In Worksheets
'If (xSheet.Name = xName_To) Then
'xSheet.Delete
'Exit For
'Else
xLast_From = xSheet.Cells(Rows.Count, xSum_Col).End(xlUp).Row
'有効データがあるか確認
If (xLast_From > xHeads) Then
xNoData = False
End If
'End If
Next
If Not (xNoData) Then
Set xSheet = Worksheets(xName_From)
xBorder = "'" & String(80, xSepa)
'最後尾に集計用のワークシートを追加
kk = Worksheets.Count
Worksheets.Add After:=Worksheets(Worksheets.Count)
If (Worksheets.Count > kk) Then
Worksheets(Worksheets.Count).Name = xName_To
Else
Exit Sub
End If
With Worksheets(xName_To)
xLast_From = xSheet.Cells(Rows.Count, xSum_Col).End(xlUp).Row
If (xLast_From > xHeads) Then
'見出しをコピー
xSheet.Rows(1 & ":" & xHeads).Copy
.Rows(1).PasteSpecial
xLast_From = xLast_From + 1
'最終行にBreak Key（クローザ）をセットアップ
xSheet.Cells(xLast_From, xKey_Col).Value = "合計"
xSheet.Cells(xLast_From, xSum_Col).Offset(0, -1).Value = "合計"
xSum = 0
xChk_Row = xHeads + 1
mm = xHeads + 1
For nn = (xHeads + 1) To xLast_From
'Break Key（集計単位の先頭位置：xKey_Colが空白ではない）を確認
If Not IsEmpty(xSheet.Cells(nn, xKey_Col).Value) Then
If (nn > xChk_Row) Then
xSum_Small = 0
'明細行を集計
For kk = (xChk_Row + 1) To (nn - 1)
xSum_Small = xSum_Small + xSheet.Cells(kk, xSum_Col).Value
Next
Application.CutCopyMode = False
'集計単位をまとめてコピー
xSheet.Rows(xChk_Row & ":" & nn - 1).Copy
.Rows(mm).PasteSpecial xlPasteValues
mm = mm + (nn - xChk_Row)
.Rows(mm).Resize(2).Insert
.Cells(mm, "A").Value = xBorder
.Cells(mm, xSum_Col).Offset(1, -1).Value = "小合計"
.Cells(mm, xSum_Col).Offset(1, 0).Value = xSum_Small
mm = mm + 2
xSum = xSum + xSum_Small
xChk_Row = nn
End If
Else
'明細行（xKey_Colが空白）
'不要？個別金額計算（C列：数量、E列：＠）
xSheet.Cells(nn, xSum_Col).Value = xSheet.Cells(nn, "C").Value * xSheet.Cells(nn, "E").Value
End If
Next
xLast_To = .Cells(Rows.Count, xSum_Col).End(xlUp).Row
.Cells(xLast_To + 1, "A").Value = xBorder
.Cells(xLast_To + 2, xSum_Col).Offset(0, -1).Value = "合計"
.Cells(xLast_To + 2, xSum_Col).Value = xSum
End If
End With
Else
MsgBox ("No Data Found!!")
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

この回答への補足

回答ありがとうございました。
凄いですね（＾０＾）
別シートですが、綺麗に計算されていました。
ただ、やはり同一シートで小計を出したいのでなかなか難しいですね～。
わざわざ時間を割いて作成ありがとうございます。
また次のステップに考えていきたいと思います。

補足日時：2013/04/01 14:52

No.6 回答者： JazzCorp 回答日時： 2013/03/29 18:56

'データシートをアクティブにして実行する

'データは明細だけ
'合計は施設名の行
'セパレータなし
'データシート直接更新版（やり直しの場合に問題あり）
Option Explicit
Sub Breaks()
Const xKey_Col = 1
Const xSum_Col = 6
Const xHeads = 1
Const xSepa = "="
Dim xSheet As Worksheet
Dim xBorder As String
Dim xSum As Long
Dim xSum_Small As Long
Dim xChk_Row As Long
Dim xLast As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xBorder = "'" & String(80, xSepa)
Set xSheet = ActiveSheet
xLast = Cells(Rows.Count, xSum_Col).End(xlUp).Row
If (xLast > xHeads) Then
xLast = xLast + 1
Cells(xLast, xKey_Col).Value = "合計"
Cells(xLast, xSum_Col).Offset(, -1).Value = "合計"
xSum = 0
xChk_Row = xHeads + 1
For nn = (xHeads + 1) To xLast
If Not IsEmpty(Cells(nn, xKey_Col).Value) Then
If (nn > xChk_Row) Then
xSum_Small = 0
For mm = (xChk_Row + 1) To (nn - 1)
xSum_Small = xSum_Small + Cells(mm, xSum_Col).Value
Next
Cells(xChk_Row, xSum_Col).Offset(, -1).Value = "小合計"
Cells(xChk_Row, xSum_Col).Value = xSum_Small
xSum = xSum + xSum_Small
xChk_Row = nn
End If
Else
Cells(nn, xSum_Col).Value = Cells(nn, "C").Value * Cells(nn, "E").Value
End If
Next
Cells(xLast, xKey_Col).Value = ""
Cells(xLast, xSum_Col).Value = xSum
Rows(xLast).Insert
Cells(xLast, "A").Value = xBorder
Else
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

No.5 回答者： CoalTar 回答日時： 2013/03/29 18:31

中太罫線も引くんでしたね。

バックアップを取ってから試してください
小計や合計はピボットテーブルで別表にするほうが良いと思いますが、勉強がてら作ってみました

Sub 駄作でも動くはず2()
'変数定義
Dim u As Long, v As Long, w As Long, i As Long
'最終行u
　 　 　u = Cells(Rows.Count, 5).End(xlUp).Row
'「小計」の数v
　 　 　Cells(u, 6).FormulaR1C1 = "=COUNTIF(C5,""小計"")"
　 　 　v = Cells(u, 6).Value
'E列選んで
　 　 　Columns("E:E").Select
'Ctrl+F 小計を検索
　 　 　Selection.Find(What:="小計", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
　 　 　 　 　 　 :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
　 　 　 　 　 　 False, MatchByte:=False, SearchFormat:=False).Activate
'アクティブセルの行w
　 　 　w = ActiveCell.Row
'その行のF列に 数式を入れる
　 　 　Cells(w, 6).Formula = "=subtotal(9,F2:F" & w - 1 & ")"
　 　 　With Range("a" & w & ":f" & w).Borders(xlEdgeBottom)
　 　 　 　 　 　.LineStyle = xlContinuous
　 　 　 　 　 　.Weight = xlMedium
　 　 　End With
'小計の個数v -1回繰り返し
　 　 　For i = 2 To v
'次の小計を検索
　 　 　Selection.FindNext(After:=ActiveCell).Activate
'その行のF列に 数式を入れる
　 　 　Cells(ActiveCell.Row, 6).Formula = "=subtotal(9,F" & w + 1 & ":F" & ActiveCell.Row - 1 & ")"

'アクティブセルの行w
　 　 　w = ActiveCell.Row
　 　 　 　 　 　With Range("a" & w & ":f" & w).Borders(xlEdgeBottom)
　 　 　 　 　 　.LineStyle = xlContinuous
　 　 　 　 　 　.Weight = xlMedium
　 　 　End With
　 　 　Next i
'合計に 数式を入れる
　 　 　Cells(u, 6).Formula = "=Subtotal(9,F2:F" & u - 1 & ")"
'セル選択
　 　 　Cells(u, 6).Select
End Sub

この回答への補足

早速の回答ありがとうございました。
ですが、'Ctrl+F 小計を検索
Selection.Find(What:="小計", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate

この行でエラーになってしまいます(t0t)

補足日時：2013/04/01 14:56

No.4 回答者： CoalTar 回答日時： 2013/03/29 17:30

Sub 駄作でも動くはず()

'変数定義
Dim u As Long, v As Long, w As Long, i As Long
'最終行u
　 　 　u = Cells(Rows.Count, 5).End(xlUp).Row
'「小計」の数v
　 　 　Cells(u, 6).FormulaR1C1 = "=COUNTIF(C5,""小計"")"
　 　 　v = Cells(u, 6).Value
'E列選んで
　 　 　Columns("E:E").Select
'Ctrl+F 小計を検索
　 　 　Selection.Find(What:="小計", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
　 　 　 　 　 　:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
　 　 　 　 　 　False, MatchByte:=False, SearchFormat:=False).Activate
'アクティブセルの行w
　 　 　w = ActiveCell.Row
'その行のF列に 数式を入れる
　 　 　Cells(w, 6).Formula = "=subtotal(9,F2:F" & w - 1 & ")"
　 　 　
'小計の個数v -1回繰り返し
　 　 　For i = 2 To v
'次の小計を検索
　 　 　Selection.FindNext(After:=ActiveCell).Activate
'その行のF列に 数式を入れる
　 　 　Cells(ActiveCell.Row, 6).Formula = "=subtotal(9,F" & w + 1 & ":F" & ActiveCell.Row - 1 & ")"
　 　 　w = ActiveCell.Row
　 　 　Next i
'合計に 数式を入れる
　 　 　Cells(u, 6).Formula = "=SUbtotal(9,F2:F" & u - 1 & ")"
'セル選択
　 　 　Cells(u, 6).Select
End Sub

No.3 回答者： cj_mover 回答日時： 2013/03/29 17:19

こんにちは。

表計算やデータベースでの一般的なテーブルとしての要件を満たしていれば、
Excelの一般機能（[データ]タブにある）[小計]（SUBTOTAL）を使うことが出来て、、
一々"小計"と入力する手間なしで、ご質問の要求はほぼ達成できます。
足りないのは、小計・合計の対象となる行のＡ列を省略してしまっていること。
または、各データ（レコード）がどの施設の物かを示す一意のキーがないこと。
誤って並べ替えてしまったりした時にデータ修復を容易にする意味でも
テーブルのレコードには、各行ごとに、それが何のデータなのかを示すデータ
が、あった方が、色々な意味で融通が利くものです。
（その方が回答も付き易いでしょう。）
見易さを意図したＡ列の表記はそれはよく見かけるやり方ですが、
普通はＡ列とＢ列の間位に施設を示すキー（名前かＩＤ）項目を置くものです。
フォーマットを（絶対的に）変えられない状況なら仕方ありませんが、
何よりもまず、現在のフォーマットを変えることを検討した方がよいとは思います。
日常的な作業が大変だというのは、日常的な作業を簡潔にする為の準備で解決する
のが正攻法で、後付けのＶＢＡでやりくりするのは、ちょっと気が進まないのですが、
さておき。
オーダー通りにＶＢＡを組んでみるとして、
せっかくＶＢＡでやるのに手入力を契機にするのも違和感があるので、
Ｅ列かＦ列の空セルをダブルクリックしたら機能するように書いてみます。
また、「前回小計をした次のセルから」より簡単にする為、
対象の行より上で一番近い行にある施設名の行の一つ下の行から、
と解釈換えをします。

' ' =====シートモジュール===== ' ' Re8017328
' ' Ｅ列Ｆ列をダブルクリックした時、Ｅ列Ｆ列共に空セルなら実行
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Dim nTop As Long, nBtm As Long
　　　　' ' Ｅ列Ｆ列以外なら抜ける。
　　If Target.Column < 5 Or Target.Column > 6 Then Exit Sub
　　　　' ' 設定したいセルが入力済なら抜ける。
　　If Application.CountA(Target.EntireRow.Columns("E:F")) Then Exit Sub
　　　　' ' ダブルクリックした行を基準に
　　With Target.EntireRow
　　　　' ' 小計する先頭行を求める。
　　　　nTop = .Cells(1).End(xlUp).Row
　　　　' ' 小計する末尾行を求める。
　　　　nBtm = .Row - 1
　　　　' ' 小計タイトルと小計をセルに設定する。
　　　　.Columns("E:F").Value = Array("小計", Application.Sum(Range("F" & nTop & ":F" & nBtm)))
　　　　' ' 罫線。
　　　　With .Resize(, 6).Borders(xlEdgeBottom)
　　　　　　.LineStyle = xlContinuous
　　　　　　.Weight = xlThick
　　　　End With
　　End With
　　　　' ' 合計を設定する行位置を求める。
　　　　nBtm = Cells(Rows.Count, "F").End(xlUp).Row + 1
　　　　' ' 合計タイトルと合計をセルに設定する
　　　　Range("E" & nBtm & ":F" & nBtm).Value = Array("合計", Application.SumIf(Range("E2:E" & nBtm - 1), "小計", Range("F2:F" & nBtm - 1)))
　　　　' ' ダブルクリックによりセルが編集状態になるのをCancelする。
　　Cancel = True
End Sub
' ' ==========================

同一のブック内に同じ内容の作業をするシートが複数ある場合は
Thisworkbookモジュールに以下を貼り付けます。
編集したくないシートがある場合は予めそのシートの名前を指定して置きます。

' ' =====Thisworkbookモジュール===== ' ' Re8017328
' ' Ｅ列Ｆ列をダブルクリックした時、Ｅ列Ｆ列共に空セルなら実行
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
　　Dim nTop As Long, nBtm As Long
　　
　　　　' ' 編集したくないシートをダブルクリックした場合なら抜ける。
　　If Sh.Name = "シート名" Then Exit Sub '　　 "シート名"　要指定
　　　　' ' Ｅ列Ｆ列以外なら抜ける。
　　If Target.Column < 5 Or Target.Column > 6 Then Exit Sub
　　　　' ' 設定したいセルが入力済なら抜ける。
　　If Application.CountA(Target.EntireRow.Columns("E:F")) Then Exit Sub
　　　　' ' ダブルクリックした行を基準に
　　With Target.EntireRow
　　　　' ' 小計する先頭行を求める。
　　　　nTop = .Cells(1).End(xlUp).Row
　　　　' ' 小計する末尾行を求める。
　　　　nBtm = .Row - 1
　　　　' ' 小計タイトルと小計をセルに設定する。
　　　　.Columns("E:F").Value = Array("小計", Application.Sum(Range("F" & nTop & ":F" & nBtm)))
　　　　' ' 罫線。
　　　　With .Resize(, 6).Borders(xlEdgeBottom)
　　　　　　.LineStyle = xlContinuous
　　　　　　.Weight = xlThick
　　　　End With
　　End With
　　　　' ' 合計を設定する行位置を求める。
　　　　nBtm = Cells(Rows.Count, "F").End(xlUp).Row + 1
　　　　' ' 合計タイトルと合計をセルに設定する
　　　　Range("E" & nBtm & ":F" & nBtm).Value = Array("合計", Application.SumIf(Range("E2:E" & nBtm - 1), "小計", Range("F2:F" & nBtm - 1)))
　　　　' ' ダブルクリックによりセルが編集状態になるのをCancelする。
　　Cancel = True
End Sub
' ' ==========================

※注
「Ｄ列Ｅ列共に空セル」の行で「Ｄ列またはＥ列をダブルクリック」で起動します。

とりあえず、以上です。

No.2 回答者： tom04 回答日時： 2013/03/29 17:01

こんにちは！

F列の数式には手を付けなくてよい訳ですよね？

単にE列に「小計」と入力されたら、F列の小計・合計を表示するようにしてみました。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim i As Long, k As Long, c As Range
If Application.Intersect(Target, Range("E:E")) Is Nothing Or Target.Count <> 1 Then Exit Sub

If Target = "小計" Then
Set c = Range("E:E").Find(what:="合計", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
c.Resize(1, 2).ClearContents
End If
i = Target.Row
k = i - 1
Do While Cells(k, "B") <> ""
k = k - 1
Loop
Target.Offset(, 1) = WorksheetFunction.Sum(Range(Cells(k, "F"), Cells(i, "F")))
With Cells(i, 1).Resize(1, 6).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Target
.Offset(1) = "合計"
.Offset(1, 1) = WorksheetFunction.SumIf(Range(Cells(1, "E"), Cells(i, "E")), "小計", _
Range(Cells(1, "F"), Cells(i, "F")))
End With
End If
End Sub 'この行まで

※　データは必ず上の行から入力　→　E列に「小計」と入力するとします。
※　すでに表示されているE列の「合計」F列の「合計額」はそのまま残しておいても
最後の行だけに「合計」を表示するようにしてみました。

こんな感じではどうでしょうか？m（_ _）m

この回答への補足

回答ありがとうございました。すごいです！！きちんと計算できました。
私の説明が悪くて申し訳ないのですが、
合計はその都度でる感じではなくて合計と入れると、今までの小計が合計されて出るようにできますか？？

あと、Ｆ列の単価の行に数字を入れると自動的にＧ列の金額の所に（数量Ｄ列×単価Ｆ列）が入るようにできますでしょうか？？？

あつかましく聞いてしまってごめんなさい。

補足日時：2013/04/01 15:35

No.1 回答者： chonami 回答日時： 2013/03/29 14:59

集計（小計）機能を使われるというのは如何でしょうか？

この回答への補足

回答ありがとうございます。
それも一つの案として検討してみます。

補足日時：2013/04/01 15:02