VBA 複数シートをひとつにまとめる方法について

VBA初心者です。

ブック内の複数シートを
ひとつにまとめる方法について

検索していて見つけた・・・・

Sub Sample()
Dim sWS As Worksheet 'データシート（コピー元）
Dim dWS As Worksheet '集約用シート（コピー先）

Set dWS = Worksheets("AllData")

'集約用シートの2行目以降を削除
dWS.UsedRange.Offset(1, 0).Clear

'各シートの2行目以降のデータを、集約用シートの末尾にコピー
For Each sWS In Worksheets
If sWS.Name <> dWS.Name Then
With sWS.UsedRange

'コピー元シートにデータが1件以上ある場合
If .Rows.Count > 1 Then
.Offset(1, 0).Resize(.Rows.Count - 1).Copy _
Destination:=dWS.Cells(Rows.Count, 1). _
End(xlUp).Offset(1, 0)
End If

End With
End If
Next sWS

'集計用シートをA列で並べ替え
dWS.UsedRange.Sort Key1:=Range("A1"), Header:=xlYes
End Sub

こちらのやり方でばっちりだったのですが
問題点がひとつだけ。

まとめたシートのみでOKなのですが
見出し行の上に工事名やら期間やらを入力する
3～4行を空けておきたいのです。

3～4行・・・・
任意の行数を空けて
その下にまとめる方法を
教えていただけないでしょうか？

よろしくお願いします。

質問者からの補足コメント

• 

  1行目の
  Sub Sample()を
  上書き保存で実行されるよう
  Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  に、書き換えました。
  
  で、
  
  '集約用シートの5行目以降を削除
  dWS.UsedRange.Offset(4, 0).Clear
  に入れ替えるました。
  
  で、
  
  上書すると、古いデータの1行目が削除されずに残り
  上書を重ねるたびに
  同じデータがその下へ下へと重なり続けていきます。
  
  上書する前に
  見出しより下はいったん削除したのち、
  あたらしいデータを入れ直してほしいのですが
  もう、どこを直せばいいのやら。
  
  お時間ございましたら
  また教えていただけると助かります。

    補足日時：2017/09/14 15:13

No.5 ベストアンサー 回答者： tom04 回答日時： 2017/09/15 11:12

No.3・4です。

＞1行目のSub Sample1()を
＞Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
＞に置き換えるだけではダメでした。

ダメとは全く反応しない！というコトでしょうか？
もしかしてそのまま標準モジュールに記載していませんか？
そうだとすれば、「Workbookのイベントプロシージャ」でなければ動きません。
VBE画面の左側の下にある「This Workbook」をダブルクリックし、表示されたVBE画面上に

＞Sub Sample1()
を
＞Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
に変更してそのままコピー＆ペーストしてみてください。

※　もちろん「標準モジュール」のコードは不要なので消去します。m(_ _)m

この回答へのお礼

ありがとうございました！
本当に感謝です！

お礼日時：2017/09/15 11:25

No.4 回答者： tom04 回答日時： 2017/09/14 23:50

No.3です。

投稿後気づきました。
並び替えが必要でしたね。

前回のコードの
＞Next k
の次に
＞.Range("A5").Sort key1:=Range("A5"), order1:=xlAscending, Header:=xlYes
の1行を追加してください。

どうも失礼しました。m(_ _)m

この回答へのお礼

ありがとうございます！
動きました！
感謝です！

あともうひとつ教えていただけないでしょうか？

上書き保存したら
自動でこのコードが実行されるようにするには
どうすればいいですか？

1行目のSub Sample1()を
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
に置き換えるだけではダメでした。
まったく理解できていないもので・・・

お時間ございましたら
また教えていただけると
大変助かります。

よろしくお願いします。

お礼日時：2017/09/15 10:35

No.3 回答者： tom04 回答日時： 2017/09/14 22:58

こんばんは！

他の方がお考えになったコードに手を付けるのは好みでないので、こちらで勝手にやってみました。

「AllData」シートの5行目に項目名があらかじめ入力してある！という前提です。
尚、「AllDate」シート以外は1行目が項目行になっていて、項目数（列数）はすべて同じ列数だという前提です。

標準モジュールです。

Sub Sample1()
Dim k As Long, lastRow As Long, lastCol As Long
Dim wS As Worksheet
With Worksheets("AllData")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
lastCol = .Cells(5, Columns.Count).End(xlToLeft).Column '//←5行目に項目行があるとする//
If lastRow > 5 Then
Range(.Cells(6, "A"), .Cells(lastRow, lastCol)).Clear
End If
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> .Name Then
Set wS = Worksheets(k)
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow, lastCol)).Copy .Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End If
Next k
.Activate
End With
MsgBox "完了"
End Sub

※　各シートのA列で最終行を取得するようにしていますので、
A列には最終行まで何らかのデータが入っているとします。

これで「AllData」シートの6行目以降にコピー＆ペーストできると思います。


A1セルに何らかのデータが入っていれば、
＞UsedRange.Rows.Count
で最終行
＞UsedRange.Columns.Count
で最終列

がそれぞれ取得できますが、途中のセルからデータが入っていると
とんでもない行（列）になります。

※　個人的に「UsedRange」は極力使わないようにしています。
データがなくても罫線などが入っていれば最終行（最終列）が変わってきます。
(データの消去や書式をクリアしても「UsedRange」のままです）m(_ _)m

No.2 回答者： poco_2 回答日時： 2017/09/14 15:51

ん？？

あ、もしかして1行目が空欄だったりしますか？
だったら分かりやすく
dWS.Rows("5:"&Rows.Count).clear
にしてしまいましょうか。

この回答へのお礼

ダメでした。

上書すると空欄が1行だけ
2行目からデータが入ってしまい
更に上書を重ねると
2～5行目までの4行分に
同じデータが繰り返し入ってしまいました。

また、お知恵をお願いします。
よろしくお願いします。

お礼日時：2017/09/14 15:59

No.1 回答者： poco_2 回答日時： 2017/09/14 14:42

見出し行が4行目とすると

集約用シートの2行目以降を削除
dWS.UsedRange.Offset(1, 0).Clear
を
集約用シートの5行目以降を削除
dWS.UsedRange.Offset(4, 0).Clear
でいいかと。

この回答へのお礼

おー！

ありがとうございました！
感謝です！

お礼日時：2017/09/14 15:02