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

質問

エクセルの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

回答No.8

n-jun · ベストアンサー

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さま
回答をどうもありがとうございました。
マクロは正しく動作しました。どうもありがとうございました。

マクロ自体は問題なく動くので、まったく問題ないのですが、
理解を進めたいため、ひとつ質問させてください。

マクロの流れは、理解したつもりなのですが、
If .UsedRange.Cells.Count < 2 Then
ここのcountがなぜ<2なのでしょうか？

UsedRangeが2以下、つまり1個という状態がうまく理解できません。
つまり、私が言っているような空シート、n-junさまの言われる
「空シートとはデータが一切ない物とします。（項目行を含め、何もない状態）」の状態で、
cells.countすると、UsedRangeが1になるということですか？

私の考えではcells.countしても、データがないので「0」になる。
なので、
If .UsedRange.Cells.Count < 1 Then
でもいいように感じています。

そこで、実際に1にしてマクロを実行すると
Set r = Intersect(.UsedRange.SpecialCells(xlTextValues), .Range("B:B"))
でエラーになります。

このあたりで意味が分からなくなります。

お時間あればご教授ください。

よろしくお願いします。

回答No.10

n-jun

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さま

何度もありがとうございます。いろいろ勉強になります。
人それぞれの手法があって興味深いです。
どうもありがとうございました。

追伸
仕事は営業マンなので、単なる仕事の効率化が目標でしたが、
マクロの初歩をかじってみると、プログラムの基本的な考え方が
分かっていないとプログラムそのものが場当たりなものになると
痛切に感じています。これを契機に精進したいと思っています。

謹んで回答を閉めさせていただきます。

回答No.9

n-jun

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さま

お返事どうもありがとうございました。
委細を了解いたしました。
重ねてお礼申し上げます。

回答No.7

n-jun

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
取違でしたらスル～して下さい。

お礼

n-junさま

ご回答どうもありがとうございました。
理解しながら進めておりますので、
お返事まで時間がかかっております。
どうもすみません。

このサンプルも大変に参考になります。
解決方法はいろいろあるのだと実感しております。

また実行結果について、ひとつ相談させてください。
たとえば、WorkbookのWorkSheetが、Sheet1,Sheet2,Sheet3とあり
仮にSheet3が空シートだった場合に、マクロがエラーで中断します。

事前に空シートを削除しておけばよいことまでは理解しました。
そこでマクロ内に、この問題を回避する処理を組み込もうと
考えたのですがうまくいきません。

良案があればどうかご教授ください。

回答No.6

redfox63

すみません

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さま

ご回答どうもありがとうございます。
Debug.Print たいへん参考になりました。
また、イミディエイトウィンドウの活用方法を知りました。
お礼申し上げます。

さて、ご呈示の内容に従い、以下のようなマクロにしました。
実行結果ですが、初回のサンプルデータでいうところの
データ群１と３以降は、合算されますが、
データ群２の部分だけが、合算されません。
rtopがセル「A7」になっているため、
マクロ処理中にスキップされてしまうことまでは
わかりましたが、解決方法が浮かびません。
rtopを強制的にセル「A1」にすると
データの先頭行に空白があった場合に
問題がありそうで良案が思い浮かびません。

質問ばかりで恐縮ですが、良案があれば
お教えください。

Sub test_macro1()

Dim rOrg As Range, rData As Range, rSum As Range
Dim rTop As Range, rWork As Range
Dim ss As String

'データ範囲を取得
Set rOrg = ActiveSheet.Range("A1").CurrentRegion
Set rWork = Intersect(ActiveSheet.UsedRange, Range("A:A"))
Set rTop = rWork.Find("キャンペーン期間")
ss = rTop.Address(0, 0)
Debug.Print rWork.Address(0, 0)
Debug.Print rTop.Address(0, 0)

'データ範囲を取得
' 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

回答No.5

redfox63

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

シートに記入されている範囲のA列のみを中質している予定なのですが
最初のデータ群の範囲しか取得してないのかも

マクロの冒頭にある
Set rWork = Intersect(ActiveSheet.UsedRange, Range("A:A"))
で取得した後
Debug.Print rWork.Address(0,0)
などとして確認してみてください

『日付』の記入列が A列なんですよね …

回答No.4

redfox63

では 日付を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さま

回答どうもありがとうございます。
ソースを見ていると、とても勉強になります。

しかしながら、なぜか連続処理がうまくいきません。
ウォッチを見ていると、

Set rTop = rWork.FindNext(rTop)

ループの初回に
Nothingとなってしまい
Exit処理されてしまいます。

つまり、１つめのデータ群には、
合計（合算）が付加されるのですが
以降のデータ群が合計（合算）されません。

ソースは単純かつ分かりやすいので、
私のPC環境固有の問題も疑っています。

EXCELのVersionをお伝えし忘れていましたが
Excel2003でWindowsXP環境です。

回答をいただきながら大変に恐縮ですが、
何かヒントはありませんでしょうか？

回答No.3

redfox63

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

お礼

redfox63さん、失礼しました。
誤って「この回答への補足」に入力してしまいまいした。
念のため「お礼内容」に同じ物を投稿しておきます。
どうぞよろしくお願いします。

---

redfox63さん、お返事が遅くなりすみません。
いただいたマクロを試したのですが、うまく動かず
マクロの修正に四苦八苦しております。

勝手ながら一部を手直したところデータ群の一つ目は
うまくsum関数を入力することができました。
ところが、データ群の2つ目に移動する
　　　　' 次のデータ範囲を取得
　　　　set rOrg = rOrg.Offset( rOrg.Rows.Count+1).Resize(1,1).CurrentRegion

ここに問題があるようで、連続処理がうまくいきません。
rOrg+1でoffsetさせると次のデータ群の先頭部にはならないようなので、
rOrg部分を、rSumにしてみましたが、うまくいきませんでした。

さらなるお知恵をお借りできますと幸いです。

以下、手を加えさせていただいたマクロ内容です。

Sub Test_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).Resize(1, 3)
' 数式 SUMを設定
rSum.FormulaR1C1 = "=SUM(R[-1]C:R[-" & rData.Rows.Count & "]C)"
' 次のデータ範囲を取得
Set rOrg = rOrg.Offset(rOrg.Rows.Count + 1).Resize(1, 1).CurrentRegion
' 取得した範囲の左上のセルが 空セルなら終了
Loop While rOrg(1, 1).Value = ""
End Sub

補足

redfox63さん、お返事が遅くなりすみません。
いただいたマクロを試したのですが、うまく動かず
マクロの修正に四苦八苦しております。

勝手ながら一部を手直したところデータ群の一つ目は
うまくsum関数を入力することができました。
ところが、データ群の2つ目に移動する
　　　　' 次のデータ範囲を取得
　　　　set rOrg = rOrg.Offset( rOrg.Rows.Count+1).Resize(1,1).CurrentRegion

ここに問題があるようで、連続処理がうまくいきません。
rOrg+1でoffsetさせると次のデータ群の先頭部にはならないようなので、
rOrg部分を、rSumにしてみましたが、うまくいきませんでした。

さらなるお知恵をお借りできますと幸いです。

以下、手を加えさせていただいたマクロ内容です。

Sub Test_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).Resize(1, 3)
' 数式 SUMを設定
rSum.FormulaR1C1 = "=SUM(R[-1]C:R[-" & rData.Rows.Count & "]C)"
' 次のデータ範囲を取得
Set rOrg = rOrg.Offset(rOrg.Rows.Count + 1).Resize(1, 1).CurrentRegion
' 取得した範囲の左上のセルが 空セルなら終了
Loop While rOrg(1, 1).Value = ""
End Sub

回答No.2

n-jun

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

Sheetをまたぐは＃１さんの方法に一票で。
ただしSheetに対してRangeの与え方をミスると、ActiveSheetに固定されますから、気をつけて下さい。

お礼

n-junさんへ
すばやくご回答いただいたのに、お返事が遅くなりました。
どうもすみません。

ご指摘の合計をfindするのも、よいアイデアだと思います。
とはいえ、書き漏らしましたが、合算部分と合計の記入は
マクロで処理する予定でした。

また、Activesheetに固定される件の情報をいただき、
どうもありがとうございます。こういった部分で、
いちいち引っかかっている状態なのでありがたいです。

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

回答No.1

tossy005

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

お礼

tossy005さま
すばやいご回答どうもありがとうございました。
とてもよいヒントになりました。
いただいた内容を元にして自分でも試行してみます。

追伸
ほかのみなさまも、ぜひお知恵をお貸しください。