[[20150522134334]] 『複数ブックの同一名シートを1つのブックにコピーax(TK) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『複数ブックの同一名シートを1つのブックにコピーする』(TK)

いつもお世話になっております。
今、各施設から集められたデータを整理したいと考えています。状況としては以下のとおりです。

・各施設が規定のエクセルフォーマットに入力し、データを送付してくる
・フォーマットには5つのシートがある(シート名は左から1,2,3,4,5)
・ファイル名は各施設の名前をつけている
(施設の名前がついた複数のファイルがあり、シート名は複数のファイル全てで同じもの(1,2,3,4,5)が使用されている、という状態です)

やりたいこと
・新規ブックを作成(新規ブックの名前は、例えば1(元のシート名のどれか))。その新規ブックに、新規ブック名と同じシート(例えば1)をそれぞれのファイルの中から取り出し、シート自体をコピーしたい
・シート自体をコピーする際に、シート名を元のファイル名に変えたい
(出来上がりとしては、最初のシート名(例えば1)が出来上がりのファイルの名前になり、その出来上がったファイルの中に、最初のぞれぞれのファイル名がついたシートが集められている、という感じをイメージしてます)

いろいろと試してみたのですがどうしてもうまくいかず、お聞きする次第です。もし何か情報の不足がありましたらお教えください。どうかよろしくお願いいたします。

< 使用 Excel:Excel2010、使用 OS:Windows7 >


追記です。マクロでの実行を考えています。よろしくお願いします
(TK) 2015/05/22(金) 14:07

このタイトルのまま検索するとmougの複数ブックのシートを1つのブックにコピーする
http://www.moug.net/tech/exvba/0060003.html
というのがあります。

これを少し変えてfor文で5回回せばできます。

(デイト) 2015/05/22(金) 15:05


申し訳ありません、もし宜しければどのように変えればよいか教えていただくことはできますでしょうか。というのも、そのサイトを見て何度か試行錯誤したものの上手くいかず、結局ここで質問させて頂いているという経緯があるためです。。。
(TK) 2015/05/22(金) 15:44

Sub Sample()
    Dim sFile As String
    Dim sWB As Workbook, dWB As Workbook
    Dim dSheetCount As Long
    Dim i As Long
    Dim c As Long
    Const SOURCE_DIR As String = "C:\Users\date\Desktop\新しいフォルダー\a\"

    Application.ScreenUpdating = False

    '指定したフォルダ内にあるブックのファイル名を取得
    For c = 1 To 5
    sFile = Dir(SOURCE_DIR & "*.xls*")

    'フォルダ内にブックがなければ終了
    If sFile = "" Then Exit Sub

    '集約用ブックを作成
    Set dWB = Workbooks.Add

    '集約用ブック作成時のシート数を取得
    dSheetCount = dWB.Worksheets.Count

    Do
        'コピー元のブックを開く
        Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)

        'コピー元の c (1,2,3,4,5)シートを集約用ブックにコピー
        sWB.Worksheets(c).Copy After:=dWB.Worksheets(dSheetCount)
        'シート名をファイル名に
        ActiveSheet.Name = sFile

        'コピー元ファイルを閉じる
        sWB.Close

        '次のブックのファイル名を取得
        sFile = Dir()
    Loop While sFile <> ""

    '集約用ブック作成時にあったシートを削除
    Application.DisplayAlerts = False
    For i = dSheetCount To 1 Step -1
        dWB.Worksheets(i).Delete
    Next i
    Application.DisplayAlerts = True

    '集約用ブックを保存して閉じる
    dWB.SaveAs Filename:="C:\Users\date\Desktop\新しいフォルダー\" & c & ".xlsx"
    dWB.Close
    Next
    Application.ScreenUpdating = False
End Sub

保存先や取り出しブック先は変更してください

(デイト) 2015/05/22(金) 16:53


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.