[[20190402123328]]　『アクティブワークシートを値貼付けで別名保存』（空豆）　ページの最後に飛ぶ

『アクティブワークシートを値貼付けで別名保存』（空豆）

作業フォルダ内に複数あるファイルを任意にバックアップをとるマクロを考ています

マクロはマクロ用のファイルに記入し、ファイルは複数あるので
ファイルを開いた際にAlt+F8でマクロを指定して実行する予定です。

開いているファイルにマクロを実行した際に
・シートを新しいブックにコピーし値で貼付け
・作業フォルダ直下に保存先フォルダ"Backup"が無ければ作成
・"Backup"フォルダにファイル名=シート名＋今日の日付、xlsx形式で保存

下記のようなマクロを書いてみたのですが、"Backup"フォルダに保存先を指定する書き方を教えて頂けますでしょうか。
作業フォルダは変わるので固定のパスではなく、ActiveWorkbook.Pathの下の"Backup"フォルダという定義をしたかったのですが、書き方で躓いています。

よろしくお願いいたします。

Sub Backup()

    Dim wb1 As Workbook, ws1 As Worksheet
    Dim wb2 As Workbook, ws2 As Worksheet
    Dim SaveDir As String
    Dim Workbook_path As String

    Workbook_path = ActiveWorkbook.Path

    Set wb1 = ActiveWorkbook
    Set ws1 = wb1.ActiveSheet
    ws1.Copy
    Set wb2 = ActiveWorkbook
    Set ws2 = wb2.ActiveSheet
    ws2.UsedRange.Value = ws2.UsedRange.Value

    SaveDir = Workbook_path & "\Backup"
    If Dir(SaveDir, vbDirectory) = "" Then
        MkDir SaveDir
    End If

    wb2.SaveAs fileName:=ws2.Name & Format(Date, "yyyymmdd"), FileFormat:=xlOpenXMLWorkbook

    wb2.Close
End Sub

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

 fileName:=
 この部分にフルパス入れればいいんでないですか？
（稲葉） 2019/04/02(火) 14:28

稲葉さま

作業フォルダのまでのパスが固定ではないので

wb2.SaveAs fileName:= SaveDir & "\" & ws2.Name & Format(Date, "yyyymmdd"), FileFormat:=xlOpenXMLWorkbook

などどすれば良いのかな？と思ったのですが上手くいかないんです。
（空豆） 2019/04/02(火) 14:37

 そういわれまして、どううまくいかないのかわからない以上、こちらとしても答えられないのですが・・・。
（稲葉） 2019/04/02(火) 14:48

稲葉さま

すみません、自己解決しました。下記のコードで欲しい結果が得られました。

wb2.SaveAs fileName:= SaveDir & "\" & ws2.Name & Format(Date, "yyyymmdd"), FileFormat:=xlOpenXMLWorkbook

ここの書き方のどこかにミスがあって、SaveDir &のところで「この名前付き引数は既に指定されています」
というエラーメッセージが出ていました。

ありがとうございました。
（空豆） 2019/04/02(火) 15:11

 たぶん、同じファイル名のブックを開いていたんじゃないですかね？
 ↓のコードを2回連続で実行してみてください。
    Sub bu()
        Dim ws As Worksheet, fp As String, fn As String
        Dim wb As Workbook
        Set ws = ActiveSheet
        fn = ws.Name & Format(Date, "yyyymmdd") & ".xlsx"
        On Error Resume Next
        Set wb = Workbooks(fn)
        On Error GoTo 0
        If wb Is Nothing Then
            fp = ws.Parent.Path & "\BackUp"
            If Dir(fp, vbDirectory) = "" Then MkDir (fp)
            ws.Copy
            Application.DisplayAlerts = False
            With ActiveWorkbook
                .Sheets(1).UsedRange.Value = .Sheets(1).UsedRange.Value
                .SaveAs Filename:=fp & "\" & fn, _
                        FileFormat:=xlOpenXMLWorkbook
            End With
            Application.DisplayAlerts = True
        Else
            MsgBox fn & "のブックは現在開かれていて、保存できません"
        End If
    End Sub
（稲葉） 2019/04/02(火) 15:14

稲葉さま

頂いたコードを実行していみたところ、2回目にMsgBoxが表示されました。
作成頂いたコードも私の書いたものより綺麗なので勉強になります。

ありがとうございました。

（空豆） 2019/04/02(火) 16:03

コメント返信：

[ 一覧(最新更新順) ]

[[20190402123328]] 『アクティブワークシートを値貼付けで別名保存』（空豆） ページの最後に飛ぶ

[[20190402123328]]　『アクティブワークシートを値貼付けで別名保存』（空豆）　ページの最後に飛ぶ