複数シートを自動集計したい

Question

担当者ごとに新規と既存それぞれシートが分かれています。
※営業は複数シートいますのでかなりのシートに分かれています。

Aシート
担当 取引先　受注or未受注　商品名　受注日(ネタ発券日)種類　　数量
田中　新規　田中工業株　受注　AAAAA222　2016年6月　金属　15,000
田中　新規　田中工業株　未受注　BBBBB444　2016年6月　アルミ　10,000
田中　新規　田中工業株　受注　 CCCC555　  2016年7月　銅　   1 ,000
田中　新規　田中工業株　受注　  DDDD777　  2016年8月　銀　  1,000

Bシート
担当　  取引先　受注or未受注　商品名　受注日(ネタ発券日)　　種類　　数量
田中　既存　佐藤商事株　未受注　UUUU1111 2016年6月　　金属　　2000
田中　既存　佐藤商事株　未受注　LLLL6666　2016年9月　　アルミ　　5000
田中　既存　佐藤商事株　受注　 OOOO7777　2016年7月　　銅　    10000
田中　既存　佐藤商事株　受注　  RRRR5555  2016年8月　　銀　      4000

それぞれ、項目数(列数)は一緒なのですべてコピペをして貼り付ければ
集計用のデータが作成できるのですが、なんせ数が多いのでできればマクロを組んで自動で集計表へすべてのデータを集計したいです。
マクロの組み方をご教授願います。

tatsu99 · Accepted Answer

以下のマクロを標準モジュールへ登録して実行してください。
-------------------------------------------------------------
Option Explicit

Const sheetName As String = "集計表"
Dim sh1 As Worksheet
Dim row1 As Long
Public Sub 集計表作成()
    Dim rowMax1 As Long
    Dim row As Long
    Dim name As String
    Dim i As Long
    Dim shno As Long
    shno = GetWorkSheetNo(sheetName)
    If shno = 0 Then
        MsgBox (sheetName & "が存在しません")
        Exit Sub
    End If
    Set sh1 = Worksheets(sheetName)
    rowMax1 = sh1.Cells(Rows.Count, 1).End(xlUp).row    'sheet1の最大行取得
    row1 = 2
    Application.ScreenUpdating = False
    '集計表より右側のシートを集計する
    For i = shno + 1 To Worksheets.Count
        Call shukei(i)
    Next
    '集計表の行が短縮されたとき、以前の行をクリアする
    For row = row1 To rowMax1
        sh1.Rows(row).Clear
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox ("処理完了")
End Sub
'1シートの集計
Private Sub shukei(ByVal shno As Long)
    Dim row2 As Long
    Dim rowMax2 As Long
    Dim sh2 As Worksheet
    Set sh2 = Worksheets(shno)
    rowMax2 = sh2.Cells(Rows.Count, 1).End(xlUp).row    'の最大行取得
    For row2 = 4 To rowMax2
        '空白行はスキップ
        If sh2.Cells(row2, 1).Value <> "" Then
            sh1.Cells(row1, 1).Value = sh2.Cells(row2, 1).Value '支店
            sh1.Cells(row1, 2).Value = sh2.Cells(row2, 2).Value '担当者
            sh1.Cells(row1, 3).Value = sh2.Cells(row2, 3).Value '新規／既存
            sh1.Cells(row1, 4).Value = sh2.Cells(row2, 4).Value '取引先
            sh1.Cells(row1, 5).Value = sh2.Cells(row2, 5).Value '受注
            sh1.Cells(row1, 6).Value = sh2.Cells(row2, 6).Value '商品名
            sh1.Cells(row1, 7).Value = sh2.Cells(row2, 7).Value '受注日
            sh1.Cells(row1, 7).NumberFormatLocal = sh2.Cells(row2, 7).NumberFormatLocal '受注日書式
            sh1.Cells(row1, 8).Value = sh2.Cells(row2, 8).Value '商品種類
            sh1.Cells(row1, 9).Value = sh2.Cells(row2, 9).Value '数量
            row1 = row1 + 1
        End If
    Next
End Sub

'ワークシートの位置を取得する
Private Function GetWorkSheetNo(ByVal sheetName As String) As Long
    GetWorkSheetNo = 0
    Dim ws As Worksheet
    Dim i As Long
    For i = 1 To Worksheets.Count
        If Worksheets(i).name = sheetName Then
            GetWorkSheetNo = i
            Exit Function
        End If
    Next
End Function
----------------------------------------
使用時の条件は、No4,No5に従ってください。

tatsu99 · Answer

No7です。
>ちなみに、集計表の右側に集計表したいシートがいくつあっても自動で集計できるという認識で合ってますか？
はい、合っています。３個あれば、３個ぶん処理します。100個あれば100個ぶん処理します。

tatsu99 · Answer

No.6です。
>上記、標準モジュールに書き込みマクロ実行してみたのですが、”処理完了”とはなるのですが
>作成した集計表のシートに何も出てきません。
>考えられる原因は何でしょうか？
>度々で恐縮ではございますが、再度ご教授願います。

集計表のシートの右側にシートがありますか？
画像の例では山本のシート、田中のシートが集計の対象です。
集計表の左側のシート（画像の例では田中(2)、sheet2）は集計の対象になりません。

tatsu99 · Answer

NO4です。
誤記訂正です。
（集計対象外にシートは左側に配置しておく）・・・・誤
（集計対象外のシートは"集計表"の左側に配置しておく）・・・・正

tatsu99 · Answer

No1です。
以下のような仕様で良いですか。
１．集計するシートの名称は"集計表"とする。このシートは存在すること。
２．集計表の見出しは、マクロでは設定しない。（人間が予め設定しておく）
３．集計対象となるシートは"集計表"の右側に配置する。
集計表の右側にあるシートを全て集計対象とする。（集計対象外にシートは左側に配置しておく）

fujillin · Answer

ANo2です

ご質問文に
＞すべてコピペをして貼り付ければ～～
とあったので、単純にコピぺで良いのかと思いましたが、被コピー部分に計算式や参照式が含まれている場合は、サンプルの単純コピーではうまくいかない可能性があります。（式等がコピーされてしまいますので）

そのような場合は、
　Range.PasteSpecial　Paste:=xlPasteValues
などを利用してください。
（「形式を選択して貼り付け-値」と同等の処理になります）

また、列数は8としてサンプルを作成しましたが、追加の図を見ると9列なのかな。

fujillin · Answer

こんにちは

＞マクロの組み方をご教授願います。
まず、1シート分をコピーするマクロを考えてみます。
次に、（ブック内全部のシートを対象と考えて良いのなら）上記の処理を全部のシート（集計用シートを除く）を対象として行えるようにループすることを考えればよろしいかと。

よくわからないところがいろいろありますが、とりあえずの考え方のサンプルとして以下に簡単な例を示しておきます。
※ 「集計用のシート」以外のシートの内容を全てまとめる例です
※ 各シートの1行目はタイトル行と仮定して2行目以降をコピーします
※ とりあえず例示の表にならって、列数は8列目までとしています。
（確認し易いように、各シートのデータ間に1行空白行を入れています）

Sub test()
　Dim ws As Worksheet
　Dim data As Range, pointer As Range

'集計用シート名
　Const Tname = "集計シート"

'集計用シートをクリア（タイトル行以外）
　Set pointer = Worksheets(Tname).Cells(2, 1)
　pointer.Resize(Rows.Count - 1).EntireRow.ClearContents

'ブック内の各シートに対してループ
　For Each ws In Worksheets
　'集計用シートは処理から除く
　　If Not ws.name = Tname Then

'1シート分のコピー処理
　　　Set data = ws.Cells(2, 1).Resize(ws.Cells(Rows.Count, 1).End(xlUp).Row - 1, 8)
　　　data.Copy Destination:=pointer
　　'次のコピー位置へポインタを移動 (1行空けてます）
　　　Set pointer = pointer.Offset(data.Rows.Count + 1)

End If
　Next ws

End Sub

tatsu99 · Answer

補足要求です。
質問1：１つのブック(ファイル)に全てのシートが格納されていますか。
質問2：まとめ用のシートを１つ作成しておくことはできますか。（一番左側に作っておきます）
一番左側にまとめ用シートがあり、右側のシートを順番にまとめていきます。
質問3：新規か既存の列がB列（２列目）にありますが、この列の見出しは空白なのですか。

複数シートを自動集計したい

以下のマクロを標準モジュールへ登録して実行してください。

No7です。

No.6です。

NO4です。

No1です。

ANo2です

こんにちは

補足要求です。

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

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

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

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