[[20150514085629]]　『店舗別売上ファイルのファイルコピー～一括更新～』（たくみ）　ページの最後に飛ぶ

『店舗別売上ファイルのファイルコピー～一括更新～印刷のマクロ化』（たくみ）

年度別フォルダ（27年度）に、店舗別（Ａ店、Ｂ店、Ｃ店・・・２０店程度、今後増減あり）のファイルがあります。店舗別ファイルには、それぞれ４月、５月・・・３月、年間合計のシートがあり、各シートには１日、２日・・・月間合計という日別カレンダーがあります。

システムから店舗別の日別売上データを抽出し、特定ファイル（上記店舗別ファイルとは別ファイル、同じフォルダに保存）に貼り付けると、そのデータが店舗別ファイルに計算式で反映するかたちにしています。（計算式はあらかじめ入力しているので、店舗別ファイルを開けば自動的に数字が反映）

現在は、年度ごとにまずＡ店のファイルを作成し、店舗数分コピーして名前を変更しています。次に、１週間ごとにシステムから日別売上データを抽出し、特定ファイルに貼り付けした後、店舗別ファイルを１つずつ開き、自動的に数字が反映したのち、上書き保存しています。また、月次実績が確定した段階で、各店舗のファイルの該当月のシートを１枚ずつ印刷しています。

今後、店舗が増加していくこと、データ更新を週ではなく日ごとに行う必要があることから、作業を効率化できないかと思い、相談させてください。

具体的には、以下３つの作業をマクロで実行できないかと考えています。

（１）元様式のファイルを１つつくり、店舗数（リストは特定ファイル内に別に作成）分のファイルを作成
（２）特定ファイル上に、データ更新のボタンを作り、そのボタンを押すと各店舗別ファイルが開き、自動更新後上書き保存（ファイルが開く、閉じるの画面展開は見せない）
（３）特定ファイル上に、印刷したいシート名称（たとえば４月）を入力すると、店舗別ファイルの対象シートを一括印刷

（１）については、店舗分のファイルを手作業でコピーし、マクロでファイル名称を取得、一括変更ということはできそうなのですが、もっとほかに良いやり方があれば教えてください。

よろしくお願いします。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 環境をつくるのが面倒なのでコードを書いただけです。バグあればご容赦。
 リスト　という名前のシートのA列に A店、B店、C店　等、 xlsx をはぶいたファイル名を列挙しておいてください。
 フォルダは、実際のものに変更してください。以下ではデスクトップ上の　"27年度" というフォルダ名にしてあります。
 また、元様式.xlsx が同じフォルダに存在していることが条件です。印刷指定シートがあるかどうかのチェックは手を抜いています。

 Sub 新規ブックの作成()
    Dim fPath As String
    Dim c As Range
    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    'フォルダの規定。　ダイアログから任意フォルダを選択させることもできますが。
    fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\27年度\"
    '店舗ファイル名（拡張子なし）が列挙されているシート
    With ThisWorkbook.Sheets("リスト")
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            fso.CopyFile fPath & "元様式.xlsx", fPath & c.Value & ".xlsx", OverWriteFiles:=True
        Next
    End With

 End Sub

 Sub 更新()
    Dim fPath As String
    Dim fName As String

    Application.ScreenUpdating = False

    'フォルダの規定。　ダイアログから任意フォルダを選択させることもできますが。
    fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\27年度\"

    fName = Dir(fPath & "*.xlsx")

    Do While fName <> ""
        If fName <> ThisWorkbook.Name And fName <> "元様式.xlsx" Then
            Workbooks.Open fPath & fName
            DoEvents
            ActiveWorkbook.Close True
        End If
        fName = Dir()
    Loop

 End Sub

 Sub 印刷()
    Dim shName As String
    Dim fPath As String
    Dim fName As String

    shName = InputBox("印刷するシート名を入力してください", "印刷指定")
    If shName = "" Then Exit Sub 'キャンセルボタン

    Application.ScreenUpdating = False

    'フォルダの規定。　ダイアログから任意フォルダを選択させることもできますが。
    fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\27年度\"

    fName = Dir(fPath & "*.xlsx")

    Do While fName <> ""
        If fName <> ThisWorkbook.Name And fName <> "元様式.xlsx" Then
            Workbooks.Open fPath & fName, UpdateLinks:=xlUpdateLinksNever
            DoEvents
            On Error Resume Next
            ActiveWorkbook.Sheets(shName).PrintOut
            On Error GoTo 0
            ActiveWorkbook.Close False
        End If
        fName = Dir()
    Loop
 End Sub

（β） 2015/05/14(木) 10:54

ありがとうございました！イメージどおりの作業ができそうです。

ただ、ファイルは共有サーバーにあるため、リストファイルがあるフォルダと同じフォルダを指定する、または任意フォルダの選択についても教えていただけないでしょうか。

よろしくお願いします。
（たくみ） 2015/05/14(木) 14:26

 マクロブックと同じフォルダということなら

 fPath = ThisWorkbook.Path & "\"

 にしてください。

（β） 2015/05/14(木) 14:45

βさん、助かりました。ありがとうございました。
（たくみ） 2015/05/14(木) 16:33

コメント返信：

[ 一覧(最新更新順) ]

[[20150514085629]] 『店舗別売上ファイルのファイルコピー～一括更新～』（たくみ） ページの最後に飛ぶ

[[20150514085629]]　『店舗別売上ファイルのファイルコピー～一括更新～』（たくみ）　ページの最後に飛ぶ