集計表を作成するマクロについて

質問

「１日」のシート
　　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　　Ｅ
１　車両番号　出発場所　到着場所　商品コード　数量
２　１　　　　東京　　　大阪　　　Ｌ　　　　　１０
３　２　　　　北海道　　東京　　　Ｍ　　　　　　５
４　３　　　　東京　　　北海道　　Ｌ　　　　　１７　
５　４　　　　福岡　　　東京　　　Ｎ　　　　　　８

「２日」のシート
　　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　　Ｅ
１　車両番号　出発場所　到着場所　商品コード　数量
２　１　　　　大阪　　　東京　　　Ｋ　　　　　　８
３　２　　　　東京　　　愛知　　　Ｌ　　　　　　７
４　３　　　　福岡　　　大阪　　　Ｎ　　　　　１７　
５　４　　　　北海道　　千葉　　　Ｎ　　　　　１３

上記のように「車両番号」「出発場所」「到着場所」「商品コード」「数量」の情報が入ったシートが日別に１枚ずつあり、月間で28～31枚が１つのファイルに入っています。

このファイルで、新しいシートを追加して、日別の車両情報の一覧を作成したいのですが、どのようにしたらよいのか教えていただけませんか？

以下の条件で作成したいと思います。

１．「Ａ１」から「Ｅ１」を新しいシートの「Ａ１」から「Ｅ１」に貼り付ける。

２．シートの「車両番号」に数字が入っている行をそのままコピーして、新しいシートに貼り付けていく。その際に、コピー元のシート番号が入ればありがたい。(無くても可)

３．日別の車両情報をスペースは開けずに下に続けて貼り付けていく。

４．月ごとに日数が異なるので、車両情報が投入されているシートのみを貼り付ける対象としたい。

以上です。
次のように表示されるようになると嬉しいです。

　　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　　Ｅ　　Ｆ
１　車両番号　出発場所　到着場所　商品コード　数量　参照シート名
２　１　　　　東京　　　大阪　　　Ｌ　　　　　１０　１日
３　２　　　　北海道　　東京　　　Ｍ　　　　　　５　１日
４　３　　　　東京　　　北海道　　Ｌ　　　　　１７　１日
５　４　　　　福岡　　　東京　　　Ｎ　　　　　　８　１日
６　１　　　　大阪　　　東京　　　Ｋ　　　　　　８　２日
７　２　　　　東京　　　愛知　　　Ｌ　　　　　　７　２日
８　３　　　　福岡　　　大阪　　　Ｎ　　　　　１７　２日
９　４　　　　北海道　　千葉　　　Ｎ　　　　　１３　２日

これが出来れば、手で「コピー・貼り付け」をしていくよりも入力ミスが少なくなりそうです。

よろしくお願いします。

回答No.2

nattocurry

やりたいことがきちんと整理されているので、あとはその通りにやれば良いだけですよ。
自分ではどこまでできて、どこが解らなくて困っているのかを、はっきりさせましょう。

たとえば、
１．「Ａ１」から「Ｅ１」を新しいシートの「Ａ１」から「Ｅ１」に貼り付ける。
なんていうのは、実際に手動でやってみて、それを「マクロの記録」すれば、コードは判ります。

このままだと、質問ではなく作成依頼になってしまいますよ。

お礼

下記のようなコードを入力して、何とか作成することができました。

右端に「参照シート名」を入れるところで苦戦しています。

---------------------------------------------------------------
Sub 集計表()
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
'----シートのデータが2行以上の場合にコピーします
If lRow >= 2 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

回答No.1

ka_na_de

下記のURLを参考にしてみてください。

参考URL：

http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_data_matome.html

お礼

大変参考になりました。

コードがいろいろあり、それぞれのコードの半分も理解していませんが、何とか形になりました。

あとは、出来あがった集計表の右端に参照シート名を入れるだけです。