[[20090507215644]]　『複数のシートを１つのシートにまとめる』（エンジェル）　ページの最後に飛ぶ

『複数のシートを１つのシートにまとめる』（エンジェル）

 １つのファイルに３１日分のシートを作っており、毎日、データを入力しています。
 １日のシートには、２０～５０のデータを入力してますが、別に新しいシートを作り、
 ３１日分のデータをまとめて表示したいと思います。また、一日一日のデータの間には、
 空欄をいれ、日別がわかりやすくしたく思います。どうやったらよいか教えて下さい！

 例） 1日分（シート）
    　A  　　　B 　　 C 　　 D  　　E  
 1  商品番号　　型　　ｻｲｽﾞ　重さ　　数量
 2   50        B     85    100     5
 3   40        H     84    100     5  
 4   55        S     25    125     2
     .    .   .   .   .   .   .   .

 例） 2日分（シート）

    　A  　　　B 　　 C 　　 D  　　E  
 1商品番号　　型　　ｻｲｽﾞ　重さ　　数量  
 2 　25        R     99    150     1
 3   50        A     80    111     5
 4

     .    .   .   .   .   .   
 集計シート

    　A  　　　B 　　 C 　　 D  　　E  
 1商品番号　　型　　ｻｲｽﾞ　重さ　　数量  
 2   50        B     85    100     5
 3   40        H     84    100     5  
 4   55        S     25    125     2
 5
 6 　25        R     99    150     1
 7   50        A     80    111     5

 *このようにしたい！また、ｴｸｾﾙファイルが１日分・２日分・・・３１日と分かれている場合、
 集計ファイルに集約する方法がありませんか？集約も同じように日の間に空欄を一行入れたいです。

 本当にやりたいのはシートごとの管理ですか、ファイルごとの管理ですか？
 シートであった場合、集計用シートには他のシートの情報を作業列として
 持つことは可能ですか。
 (Mook)

 Mook様、ご迷惑をおかけします。
 今、管理方法としては、シートごとの管理とファイルごとの管理をしています。
 それは、集計する段間でどちらがやりやすいか試しにやっています。
 現在は、１から３１日までのデータをそれぞれコピーし、集計表へ張り付けています。
 「集計用のシートには他のシート情報を作業列として持つことは可能か」の問いに対
 しましては可能です！
 何か良いアイデアがあればよろしくお願いします。

 #勝手に改行を入れました。先頭にスペースを入れると整形できます。

 INDIRECT を使用すれば、計算式でできるかと思いましたが、面倒になってしまったので、
 マクロでの例です。
 計算式で実現したい場合は、他の回答をお待ちください。

 集計シートのタブを右クリックでコードの表示、で表示されたウィンドウに
 下記をコピー後、EXCEL に戻って ALT + F8 で gatherData を実行してみてください。

 集計 シートの中身はクリアされるので、ファイルのバックアップ後に実行ください。

 Sub gatherData()
    Dim dstWS As Worksheet
  '★★ 集計のシート名を指定
    Set dstWS = Worksheets("集計")
    dstWS.Cells.Clear

  '★★ 先頭のシート名を指定
    Worksheets("1日分").Range("A1:E1").Copy Destination:=dstWS.Range("A1:E1")

    Dim dstRow As Long
    dstRow = 2

    Dim lastRow As Long
    Dim ws As Worksheet
    For Each ws In Worksheets
        If InStr(ws.Name, "日分") > 0 Then
            lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
            If lastRow > 1 Then
 '★★ 空白行にしたかったら次行を書き換え
                dstRow = addHeader(dstWS, ws.Name, dstRow)
           '--- dstRow = dstRow + 1
                ws.Range("A2:E" & lastRow).Copy Destination:=dstWS.Range("A" & dstRow)
                dstRow = dstRow + lastRow - 1
            End If
        End If
    Next
End Sub

 Function addHeader(dstWS As Worksheet, wsName As String, dstRow As Long) As Long
     With dstWS.Range("A" & dstRow).Resize(1, 5)
        .Merge
        .Value = wsName
        .Interior.ColorIndex = 35
    End With
    addHeader = dstRow + 1
 End Function
 (Mook)

Mookさん、ありがとうございます！早速やってみましたら望んでいる通りになりました。お世話になりました！

＊　もし良ければ、フォルダー内の各ファイルの場合の集計ファイルへの移動方法がわかれば教えていただけませんか？

 フォルダ内のファイルを集計する場合、ファイルがどのような順序で読み込まれるか
 簡単には制御できません。

 あらかじめファイル名がわかっているのであれば（データ01日分.xls ... のように）、
 そのファイルを指定して読み込むのが一つの手ですが、規則性はあるでしょうか。

 あるいは、読み込む順序は問わないのでしょうか。
 (Mook)

大変申し訳ありません。
読み込む順序は日にちの若い順が理想です。
フォルダー内に３１個のファイルが作成してあり、ファイル名は、1日分.xls ...31日分と決まっています。
以上の内容で足りますか？
よろしくお願いします！

 ファイル名の数値は半角である前提です。
 また集計ファイルとデータファイルは同じフォルダにある場合での例です。

 Sub gatherDataFromWB()
    Dim dstWS As Worksheet
    Set dstWS = ActiveSheet
    dstWS.Cells.Clear

    Dim dstRow As Long
    dstRow = 1

    getDataFromWB dstWS, dstRow, ThisWorkbook.Path & "\1日分.xls", True
    Dim wsNum As Long
    For wsNum = 2 To 31
        getDataFromWB dstWS, dstRow, ThisWorkbook.Path & "\" & wsNum & "日分.xls"
    Next
 End Sub

 Sub getDataFromWB(dstWS As Worksheet, dstRow As Long, fileName As String, _
                   Optional copyHeader As Boolean = False)
    If Dir(fileName) = "" Then
        MsgBox fileName & "がありません"
        Exit Sub
    End If

 '--- ファイルのオープン
    Dim wb As Workbook
    Set wb = Workbooks.Open(fileName)

 '--- オプション：先頭行のコピー
    If copyHeader = True Then
        wb.Worksheets(1).Range("A1").Resize(1, 5).Copy _
            Destination:=dstWS.Range("A" & dstRow).Resize(1, 5)
        dstRow = dstRow + 1
    End If

 '--- ファイル名の記載
    With dstWS.Range("A" & dstRow).Resize(1, 5)
        .Merge
        .Value = Left(wb.Name, Len(wb.Name) - 4)
        .Interior.ColorIndex = 35
    End With
    dstRow = dstRow + 1

 '--- データのコピー
    Dim lastRow As Long
    lastRow = wb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
    If lastRow > 1 Then
        wb.Worksheets(1).Range("A2:E" & lastRow).Copy Destination:=dstWS.Range("A" & dstRow)
        dstRow = dstRow + lastRow - 1
    End If

 '--- ファイルのクローズ
    wb.Close
 End Sub
 シートモジュールでもよいですが、標準モジュールに入れて使った方が今後の
 ためにはよいかも知れません。
 　※VBE（Microsoft Visual Basic と書いてあるWindow）⇒挿入⇒標準モジュール
 (Mook)

 ありがとうございました。思った通りの動作になっています。
 今回のご鞭撻でいろいろ勉強になりました。
 Mookさんへ

 解決したようでなによりです。
 今月はよいかと思いますが、来月は大丈夫でしょうか。
 特に2月は。。。

 質問とは関係ない話ですが、質問によりハンドル名は変えない方が良いと思いますよ。
 勘違いでしたら、大変失礼いたしました。
 (Mook)

コメント返信：

[ 一覧(最新更新順) ]

[[20090507215644]] 『複数のシートを１つのシートにまとめる』（エンジェル） ページの最後に飛ぶ

[[20090507215644]]　『複数のシートを１つのシートにまとめる』（エンジェル）　ページの最後に飛ぶ