エクセルで集計表を作成するマクロで悩んでいます。

質問

エクセルで集計表を作成するマクロで悩んでいます。

日付ごとにシート別に分かれたデータを「集計表」として新しいシートに集めたいと思っています。

●元データに関して
　1行目は空欄
　2行目は表の名前
　3行目は日付
　4～7行目は番号・数量などの項目
　8行目から多い場合で50行目くらいまで番号ごとの情報が並んでいます。
　AC列まで並んでいます。・・・・・・●画像左上が元データ

●このファイルから、(1)集計表という新しいシートを作成して(2)そのファイルに日付ごとの
データが下方向に集まるように集計したいと思っています。

そこで、次のＶＢＡを作成しました。

Sub 集計表()
Dim ws As Worksheet
For Each ws In Worksheets
’AD列にシート名を入れる
ws.Range("AD1:AD100").Value = ws.Name
Next ws
Dim newSh As String
Dim Sh As Worksheet, myFlag As Boolean
newSh = "集計表"
myFlag = False
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name = newSh Then
myFlag = True
'----全データシートのデータをクリアし、先頭へ移動します
Worksheets(newSh).Cells.ClearContents
Worksheets(newSh).Move before:=Sheets(1)
Exit For
End If
Next Sh
'----全データシートを先頭へ追加します
If myFlag = False Then
ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh
End If
Worksheets(2).Select
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("集計表").Select
ActiveSheet.Paste

Dim i As Integer
Dim lRow As Long, lCol As Long, lRow2 As Long
Application.ScreenUpdating = False
'----列見出しをコピーします
Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1")
For i = 2 To Worksheets.Count
With Worksheets(i)
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'----シートのデータが8行以上の場合にコピーします
If lRow >= 8 Then
lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
.Activate
.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
End If
End With
Next i
Worksheets(1).Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub

この方法だと、「番号」などを含むシートごとの全ての情報がコピーされてしまいます。
●左下画像

これを「(1)１枚目のシートの１行目から７行目(2)１枚目シートの８行目からＡ列に1以上の番号が
入っている行(3)２枚目シートの８行目からＡ列に1以上の番号が入っている行(4)３枚目シートの・・・」というように全てのシートに対して集計することはできないでしょうか。
●右下画像

ＶＢＡを始めたばかりなので、まだ、あまり理解できていません。

回答No.2

n-jun · ベストアンサー

n-junです。

＞Ｉ列とＪ列・Ｋ列とＬ列など、結合されたセルがあることが問題でしょうか？
元のコードでは問題なかったんですよね？

それであれば支障はないはずなのですが。

結合セルは見た目をよくするには便利ですけど、
集計などを行なうには余りよいものではない感じはします。

補足

＞'----列見出しをコピーします
＞'----１～７行目をコピペ
＞Worksheets(2).Range("1:7").Copy Worksheets(1).Range("A1")
原因は分かりませんが、「Range("1:7")」を「Range("1:1")」にするとエラーが消えました。

1～7行目をコピーする部分を削除したら、集計表シートの2行目から下方向に
その他シートの情報が続けてコピーされたので、後ろに以下のＶＢＡを加えて
対応できました。

Worksheets(2).Select
Rows("2:7").Select
Selection.Copy
Sheets("集計表").Select
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Range("A3:f3").Select
Selection.ClearContents
Range("A1").Select

回答No.1

n-jun

検証はしていないのですが。

Worksheets(2).Select
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("集計表").Select
ActiveSheet.Paste

ここは不要だと思うんです。

あとは最初に１～７行目を貼付け、
その後は各シートの８～最終行を貼付ければ良いのでは？

Sub 集計表_Test()
Dim ws As Worksheet
For Each ws In Worksheets
'AD列にシート名を入れる
ws.Range("AD1:AD100").Value = ws.Name
Next ws
Dim newSh As String
Dim Sh As Worksheet, myFlag As Boolean
newSh = "集計表"
myFlag = False
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name = newSh Then
myFlag = True
'----全データシートのデータをクリアし、先頭へ移動します
Worksheets(newSh).Cells.ClearContents
Worksheets(newSh).Move before:=Sheets(1)
Exit For
End If
Next Sh
'----全データシートを先頭へ追加します
If myFlag = False Then
ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh
End If

Dim i As Integer
Dim lRow As Long, lCol As Long, lRow2 As Long
Application.ScreenUpdating = False
'----列見出しをコピーします
'----１～７行目をコピペ
Worksheets(2).Range("1:7").Copy Worksheets(1).Range("A1")

For i = 2 To Worksheets.Count
With Worksheets(i)
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'----シートのデータが8行以上の場合にコピーします
If lRow >= 8 Then
lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
.Activate

'----８～最終行までをコピーする
.Range(Cells(8, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
End If
End With
Next i
Worksheets(1).Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub

コードは質問の範囲だけ変更してます。
ご参考になれば。

補足

８行目から最終行までをコピーするところがうまく行きません。
「.Range(Cells(8, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)」
に「結合されたセルの一部を変更することはできません。」というエラーが出てしまいます。

Ｉ列とＪ列・Ｋ列とＬ列など、結合されたセルがあることが問題でしょうか？