エクセルVBAによる不連続データ群の合算と、ワークシートをまたぐ連続処理について

Question

エクセルのVBAによる、合算処理が上手くいかずに困っています。
現在の状況ですが、１つのワークブックト中に、
いくつかのシートに分かれたデータ群があります。
それぞれのシートごとのデータ群で合算したいと思っています。
１つのデータ群に対してのVBAは作成できたのですが、
それぞれのデータ群ごとに合算しつつ、シートをまたいで
連続処理することができません。
お知恵を拝借できれば幸いです。

Workbook Sheet1の内容
　　　[ A ][ B ][ C ][ D ][ E ]
[ 1]　日付 品名 予算 金額 差額
[ 2]　3/1  aaa  1000  200　800
[ 3]　3/1  bbb    500   100　400
[ 4]　3/1  ccc    600   200　400
[ 5]　　　合計  2100 500  1600
[ 6]　
[ 7]　日付 品名 予算 金額 差額
[ 8]　2/1  ddd   1000  ５00　 500
[ 9]  2/1  eee   2000   600　1400
[10] 2/1  fff   1800  1200　 600
[11]　　合計  4800 2300 2500
[12]
[13]　日付 品名 予算 金額 差額
　　　以下、同一シート内にデータ群が続いていき、
　　　さらにWoorkbook Sheet2, Sheet3 ..... と続きます。


　　　以下、自作のVBA

Sub sample()

    Dim my_last_row As Long '最終行の行数用
    Dim my_last_address_sum As Long  '最終行から一つ下のセル（合計用のセル）のアドレス取得用

    my_last_row = Range("D65536").End(xlUp).Row
    my_last_address_sum = Range("D65536").End(xlUp).Offset(1).Address(RowAbsolute:=False)
    
    '=sum関数の埋め込み
    Range(my_last_address_sum).Formula = "=sum(C1:" & "C" & Format(my_last_row) & ")"
    
    '=sum関数を埋め込んだセルのコピー
    Range(my_last_address_sum).Copy

    '=sum関数を埋め込んだセルから、右に１つ分だけセルを移動する
    Range(my_last_address_sum).Offset(0, 1).Select
    
    '移動したセルを基準にして、右に2つ分だけセルを拡張する（合計3セルを選択する）
    Range(ActiveCell, ActiveCell.Offset(0, 2)).Select
    
    '選択した3つのセルに対して、=sum関数を埋め込んだセルのペーストする
    ActiveSheet.Paste

    'セルA1に戻る
   Range("A1").Select

End Sub

n-jun · Accepted Answer

ANo.7です。

＞仮にSheet3が空シートだった場合に、マクロがエラーで中断します。
空シートとはデータが一切ない物とします。
（項目行を含め、何もない状態）

Sub　test2()
　Dim　ws　As　Worksheet
　Dim　r　As　Range
　Dim　rr　As　Range,　rs　As　Range

　For　Each　ws　In　Worksheets
　　　　　With　ws
　　　　　　　　　　If　.UsedRange.Cells.Count　<　2　Then
　　　　　　　　　　　　　Set　r　=　Nothing
　　　　　　　　　　Else
　　　　　　　　　　　　　Set　r　=　Intersect(.UsedRange.SpecialCells(xlTextValues),　.Range("B:B"))
　　　　　　　　　　End　If
　　　　　End　With

　　　　　If　Not　r　Is　Nothing　Then
　　　　　　　　For　Each　rr　In　r.Areas
　　　　　　　　　　　　Set　rs　=　rr.Offset(1).Resize(rr.Rows.Count　-　1)
　　　　　　　　　　　　With　rr.Offset(rr.Rows.Count).Resize(1)
　　　　　　　　　　　　　　　　　.Formula　=　"合計"
　　　　　　　　　　　　　　　　　.Offset(,　1).Resize(,　3).Formula　=　"=SUM("　&　rs.Offset(,　1).Address(0,　0)　&　")"
　　　　　　　　　　　　End　With
　　　　　　　　Next
　　　　　End　If
　Next
　Set　r　=　Nothing
　Set　rs　=　Nothing
End　Sub
ご参考になれば。

n-jun · Answer

ANo.8です。
まだ閉じられていなかったので、Find版を考えてみました。
素人考えなのでごちゃごちゃしてしまいましたが。

Sub　try()
　Dim　ws　As　Worksheet
　Dim　AreaRange　As　Range
　Dim　FindRange　As　Range
　Dim　F_Address　As　String

　For　Each　ws　In　Worksheets
　　　　　With　ws
　　　　　　　　　　Set　FindRange　=　.Range("A:A").Find(　_
　　　　　　　　　　　　　　　　　　　　　　　　　　What:="日付",　After:=.Range("A"　&　Rows.Count))
　　　　　　　　　　If　Not　FindRange　Is　Nothing　Then
　　　　　　　　　　　　　F_Address　=　FindRange.Address
　　　　　　　　　　　　　Do
　　　　　　　　　　　　　　　　　Set　AreaRange　=　FindRange.CurrentRegion
　　　　　　　　　　　　　　　　　　　　　If　Application.CountIf(AreaRange,　"合計")　<　1　Then
　　　　　　　　　　　　　　　　　　　　　　　　With　AreaRange.Offset(AreaRange.Rows.Count,　1).Resize(1,　1)
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.Value　=　"合計"
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.Offset(,　1).Resize(1,　3).Formula　=　"=sum("　&　AreaRange.Offset(1,　2)　_
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　.Resize(AreaRange.Rows.Count　-　1,　1).Address(0,　0)　&　")"
　　　　　　　　　　　　　　　　　　　　　　　　End　With
　　　　　　　　　　　　　　　　　　　　　End　If
　　　　　　　　　　　　　　　　　Set　FindRange　=　.Range("A:A").FindNext(FindRange)
　　　　　　　　　　　　　Loop　Until　F_Address　=　FindRange.Address
　　　　　　　　　　End　If
　　　　　End　With
　Next
　Set　FindRange　=　Nothing
　Set　AreaRange　=　Nothing
End　Sub
”Ａ列の「日付」”を検索してます。
Findメソッドは引数を余り省略しない方がよいと、諸先輩方の回答で勉強しました。
今回は検索開始位置をＡ列の一番最後からにしています。
よって初めに見つけるのは各シートのＡ１になるはずです。

ご参考になれば。

n-jun · Answer

ANo.8です。

>If .UsedRange.Cells.Count < 2 Then
>ここのcountがなぜ<2なのでしょうか？
>私の考えではcells.countしても、データがないので「0」になる。
>なので、
>If .UsedRange.Cells.Count < 1 Then
>でもいいように感じています。
>そこで、実際に1にしてマクロを実行すると
>Set r = Intersect(.UsedRange.SpecialCells(xlTextValues), .Range("B:B"))
>でエラーになります。
実は私も当初同じ考えでコードを作ったのですが、同じエラーになりました。
エラーが発生した際に
If .UsedRange.Cells.Count < 1 Then
にマウスを合わせてみると
.UsedRange.Cells.Count = 1
となってます。
即ちアクティブなセル１個をカウントしていると判断し、"<2"としました。
素人考えなので正確かはわかりませんが、結果から多分そうだと思います。

n-jun · Answer

ANo.2です。

初めの質問だけでの解釈ですが。
Sub　test()
　Dim　ws　As　Worksheet
　Dim　r　As　Range
　Dim　rr　As　Range

　For　Each　ws　In　Worksheets
　　　　　With　ws
　　　　　　　　　　Set　r　=　Intersect(.UsedRange.SpecialCells(xlTextValues),　.Range("B:B"))
　　　　　End　With

　　　　　For　Each　rr　In　r.Areas
　　　　　　　　　With　rr.Offset(rr.Rows.Count).Resize(1)
　　　　　　　　　　　　　　.Formula　=　"合計"
　　　　　　　　　　　　　　.Offset(,　1).Formula　=　"=SUM("　&　rr.Offset(,　1).Address(0,　0)　&　")"
　　　　　　　　　　　　　　.Offset(,　2).Formula　=　"=SUM("　&　rr.Offset(,　2).Address(0,　0)　&　")"
　　　　　　　　　　　　　　.Offset(,　3).Formula　=　"=SUM("　&　rr.Offset(,　3).Address(0,　0)　&　")"
　　　　　　　　　End　With
　　　　　Next
　Next
　Set　r　=　Nothing
End　Sub
取違でしたらスル～して下さい。

redfox63 · Answer

すみません

Set rTop = rWork.FindNext( rTop )
で rTopが Nothingになってしまうのは Findを実行していないためです

マクロの冒頭を
　　Set rOrg = ActiveSheet.Range("A1").CurrentRegion
　　Set rWork = Intersect(ActiveSheet.UsedRange, Range("A:A"))
　　Set rTop = rWork.Find("日付")
と変更してください

redfox63 · Answer

rWorkの取得範囲は正常なのでしょうか？

シートに記入されている範囲のA列のみを中質している予定なのですが
最初のデータ群の範囲しか取得してないのかも

マクロの冒頭にある
Set rWork = Intersect(ActiveSheet.UsedRange, Range("A:A"))
で取得した後
Debug.Print rWork.Address(0,0)
などとして確認してみてください

『日付』の記入列が A列なんですよね …

redfox63 · Answer

では 日付をFindメソッドで探しましょう

Sub Macro1()
　　Dim rOrg As Range, rData As Range, rSum As Range
　　Dim rTop As Range, rWork As Range
　　Dim ss As String
　　'データ範囲を取得
　　Set rTop = ActiveSheet.Range("A1")
　　Set rOrg = rTop.CurrentRegion
　　Set rWork = Intersect(ActiveSheet.UsedRange, Range("A:A"))
　　ss = rTop.Address(0, 0)
　　Do
　　　　' 取得範囲が2行以下なら処理中断
　　　　If rOrg.Rows.Count < 2 Then
　　　　　　Exit Do
　　　　End If
　　　　' 取得範囲からデータ領域のみを抽出
　　　　Set rData = rOrg.Offset(1).Resize(rOrg.Rows.Count - 1)
　　　　'合計行があるなら 1行マイナス 無ければ『合計』を転記
　　　　If rData(rData.Rows.Count, 2) = "合計" Then
　　　　　　Set rData = rData.Resize(rData.Rows.Count - 1)
　　　　Else
　　　　　　rData.Offset(rData.Rows.Count, 1).Resize(1, 1).Value = "合計"
　　　　End If
　　　　' 合計の数式範囲を設定
　　　　Set rSum = rData.Offset(rData.Rows.Count, 2).Resize(1, rData.Columns.Count - 2)
　　　　' 数式 SUMを設定
　　　　rSum.FormulaR1C1 = "=SUM(R[-1]C:R[-" & rData.Rows.Count & "]C)"
　　　　' 次のデータ範囲を取得
　　　　Set rTop = rWork.FindNext(rTop)
　　　　If rTop Is Nothing Then
　　　　　　Exit Do
　　　　End If
　　　　Set rOrg = rTop.CurrentRegion
　　　　' 取得した範囲の左上のセルが 空セルなら終了
　　Loop While rTop.Address(0, 0) <> ss
End Sub

# 我々回答者は 質問内容や補足事項を手がかりに回答するしかありません
# 例示のレイアウトでテストを行ったりしておりますのでこれ以外のケースを想定していません

redfox63 · Answer

1)『日付』のセルを基点に CurrentRegionでデータ範囲を取得
1-1) 取得範囲が2行未満の場合処理中断
2) 取得したデータ範囲を 題目と合計行の分小さくする
3) 2)の範囲から数式SUMの範囲を選定
4) FomulaR1C1で数式を設定
5) 1)で取得した範囲を その範囲のRows.Count+1ずらして 1)から実行

Sub Macro1
　　dim rOrg as Range, rData as Range, rSum as Range
　　'データ範囲を取得
　　set rOrg = ActiveSheet.Range("A1").CurrentRegion
　　do
　　　　' 取得範囲が2行以下なら処理中断
　　　　if rOrg.Rows.Count < 2 then
　　　　　　exit do
　　　　end if
　　　　' 取得範囲からデータ領域のみを抽出
　　　　set rData = rOrg.Offset(1).Resize( rOrg.Rows.Count - 1 )
　　　　’合計行があるなら 1行マイナス 無ければ『合計』を転記
　　　　if rData(rData.Rows.Count, 2) = "合計" then
　　　　　　set rData = rData.Resize( rData.rows.Count -1 )
　　　　else
　　　　　　rData.Offset( rData.Rows.Count, 1).Resize(1,1).Value = "合計"
　　　　end if
　　　　' 合計の数式範囲を設定
　　　　set rSum = rData.Offset( rData.Rows.Count,2)
　　　　' 数式 SUMを設定
　　　　rSum.fomulaR1C1 = " =SUM(R[-1]C:R[-" & rData.rows.Count & "])"
　　　　' 次のデータ範囲を取得
　　　　set rOrg = rOrg.Offset( rOrg.Rows.Count+1).Resize(1,1).CurrentRegion
　　　　' 取得した範囲の左上のセルが 空セルなら終了
　　loop while rOrg(1,1).Value = ""
End Sub

n-jun · Answer

”合計”という文字が既に入っているのであれば、Findで探すってのもありなのかも。

Sheetをまたぐは＃１さんの方法に一票で。
ただしSheetに対してRangeの与え方をミスると、ActiveSheetに固定されますから、気をつけて下さい。

tossy005 · Answer

データ群同士の間に１行あいているルールがあるならば、
空白行であり、かつ２行以上空白行が続いていない行に対し合計を埋め込めばよいと思います。
または、ご使用されているmy_last_row = Range("D65536").End(xlUp).RowのRangeを前回合計を埋め込んだセルからD65536までに変更し、前回合計を埋め込んだセルが返ってくるまで繰り返すか。
シートをまたぐのは、
Dim xlsheet as worksheet
for each xlsheet In Worksheets
     'シート毎の処理
next
という感じでできると思います。

エクセルVBAによる不連続データ群の合算と、ワークシートをまたぐ連続処理について

ANo.7です。

ANo.8です。

ANo.8です。

ANo.2です。

すみません

この回答への補足

rWorkの取得範囲は正常なのでしょうか？

では 日付をFindメソッドで探しましょう

1)『日付』のセルを基点に CurrentRegionでデータ範囲を取得

この回答への補足

”合計”という文字が既に入っているのであれば、Findで探すってのもありなのかも。

データ群同士の間に１行あいているルールがあるならば、

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

では日付をFindメソッドで探しましょう