• ベストアンサー

保存場所を指定する（VBA)

エクセルでVBAを使用し、業務書類を作っていますが、 書類を保存する際に、指定場所に自動で保存させたいと思っています。 現在使用しているものは、下記の通りですが、 これでは、元ファイルと同じ場所に保存されてしまうので 元ファイルを削除されてしまうなどの恐れがあります。 そこで、フォルダを作りそのフォルダに自動的に保存したいと 思っています。フォルダは元ファイルがある下に作りたいと思います。 宜しくお願いします。 下記現在のものです。 Sub 保存() タイトル = "確認" メッセージ = "ファイルを保存します。よろしいですか？" スタイル = vbYesNo + vbQuestion + vbDefaultButton1 + vbApplicationModal yesno = MsgBox(メッセージ, スタイル, タイトル) If yesno = vbYes Then Sheets("新築").Select パス = ActiveWorkbook.Path 別名 = Application.InputBox(prompt:="拡張子（.xls）は不要です", _ Title:="保存用のブック名を入力してください", Type:=2) ' 別名 = パス & "\" & 別名 & ".xls" Sheets(Array("見積新築")).Copy ActiveWindow.DisplayWorkbookTabs = False ActiveWorkbook.SaveAs Filename:=別名 ActiveWorkbook.Close MsgBox "書類を保存しました。", vbInformation, "保存完了" End If End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • merlionXX
  • ベストアンサー率48% (1930/4007)
回答No.1

現在は > 別名 = パス & "\" & 別名 & ".xls" となっているので元のBOOKと同じところに保存されますが、新しいフォルダを元ファイルがある下に作っておけば、 別名 = パス & "\" & "新しいフォルダ名\" & 別名 & ".xls" でOKです。

sumi3377
質問者

お礼

なるほど、簡単なことですね。 ありがとうございました。 予定通り完成しました。

その他の回答 (2)

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.3

特別に１つのフォルダを（手動操作で）作るのでしょう。 フォのホルダへの保存は動かないのでしょう。 そのフォルダまでのフルパス＋ファイル名 で保存したら仕舞いでしょう。何が疑問か。 ファイル名をその都度指定させるのかの方が難しさを「左右する。 例では都度にんげんが指定らしいが。 ファイル保存のダイアロウグもVBAで扱えるから調べてみたら。そのダイアロウグの保存先もコードで固定（指定）できるよ。

sumi3377
質問者

お礼

予定通り完成しました。 ありがとうございました。

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.2

フォルダ名＋"\"＋ファイル名 で条件を与えるのが可能なら。 ＞別名 = Application.InputBox(prompt:="拡張子（.xls）は不要です", _ ＞Title:="保存用のブック名を入力してください", Type:=2) ' ＞別名 = パス & "\" & 別名 & ".xls" を 別名 = Application.InputBox(prompt:="フォルダ名\ファイル名でお願いします" & vbLf & "拡張子（.xls）は不要です", _ Title:="保存用のブック名を入力してください", Type:=2) ' If Dir(パス & "\" & Split(別名, "\")(0), vbDirectory) = "" Then MkDir パス & "\" & Split(別名, "\")(0) 別名 = パス & "\" & 別名 & ".xls" としてみるとか？

sumi3377
質問者

お礼

予定通り完成しました。 皆様のアドバイスが大変参考になりました。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • マクロでの自動保存

    エクセルで作ったデータをボタン一つで自動的に特定のフォルダーに 保存するマクロを作りたいのですが、色々なサイトを参考に保存名前を 付けて保存するプログラムまでは組めたのですが、特定のフォルダに 保存していくプログラムがうまく動きません。 下記に作成したコードを記載するので、アドバイスお願いします。 Sub データ保存() Sheets("シート名").Select パス = ActiveWorkbook.Path 別名 = Application.InputBox(prompt:="入力例.12345", _ Title:=" ファイル名を入力して下さい", Type:=2) 別名 = パス & "\" & 別名 & ".xls" Sheets("シート名").Copy ActiveWorkbook.SaveAs Filename:=別名 ActiveWorkbook.Close End Sub

  • GetSaveAsFilenameでフォルダを指定したいのですが？

    すいません。マクロ初心者です。 (1)以下のプロシージャで保存するときに、フォルダを指定したいのですがどこにフォルダ名を入れたらいいかわかりません。 (2)XPのエクセル2003で作成したのですが、vistaのエクセル2007で使用すると保存時に拡張子.xlsが付かずエクセルファイルになりません。 ご教授ください。 Sub シート保存2() Dim Answer3 Dim 既定ファイル名 As String Dim 保存ファイル名 As Variant Answer3 = MsgBox("本当に保存しますか？", vbYesNo) If Answer3 = vbNo Then MsgBox ("キャンセルしました。") Exit Sub End If Sheets("保存シート").Select Application.CutCopyMode = False Sheets("保存シート").Copy 既定ファイル名 = Range("V7") & ".xls" 保存ファイル名 = Application.GetSaveAsFilename(既定ファイル名) If 保存ファイル名 = False Then MsgBox "保存は中止されました。" ActiveWorkbook.Close (False) Else ActiveWorkbook.SaveCopyAs 保存ファイル名 ActiveWorkbook.Close (False) End If End Sub よろしくお願いします。

  • VBAでVBAを削除？

    作業中のブックから一枚のシートを以下のSub 別ファイル保存()プロシージャで別のブックとして保存します。それはうまくいったのですが、この元になるシートには Private Sub Worksheet_SelectionChange(ByVal Target As Range) '途中略 End Sub と Private Sub Worksheet_Deactivate() '途中略 End Sub の二つのVBAが記述してあり、これまで一緒に別のブックに入ってしまいます。 これを防ぐにはどのようにすればよいのでしょうか？ Sub 別ファイル保存() mypath = ThisWorkbook.Path fn = Sheets("Declarations").Range("H15").Value & Format(Date, "yymmdd") ffn = mypath & "\" & fn & ".xls" Sheets("Declarations").Copy ActiveWorkbook.SaveAs Filename:=ffn ActiveWorkbook.Close End Sub

  • VBAでも新規ファイル作成

    Excel2003です。 下記のコードであるシートを別ファイルにして保存するコードを書いています。ただ、このコードでは、コピー元のシートにExcel関数が入っているために、出来上がった新規ファイルを開くときに常に”リンクの更新”を聞かれてしまいます。リンクの更新をする必要はないのでファイルを開くたびに”更新しない”を選択してもよいのですが、初めからこの”リンクの更新”メッセージが出ないようにするには何か良い手立てはないでしょうか？ ------------------------------------------------------------- Sub ファイル作成() '報告書を"名前を付けて保存" Sheets("Sheet1").Select Dim 既定ファイル名 As String Dim 保存ファイル名 As Variant 既定ファイル名 = "新規報告書" 保存ファイル名 = Application.GetSaveAsFilename(既定ファイル名, "Excel ブック(*.xls),*.xls") If 保存ファイル名 = False Then MsgBox "保存は中止されました。" Sheets("Sheet1").Select Else With ThisWorkbook.ActiveSheet Workbooks.Add .Copy After:=ActiveWorkbook.Sheets(1) Application.DisplayAlerts = False ActiveWorkbook.Sheets(1).Delete Application.DisplayAlerts = True ActiveWorkbook.SaveAs 保存ファイル名, xlNormal ActiveWorkbook.Close False End With Sheets("Sheet1").Select End If End Sub ---------------------------------------------------------------

  • ファイルの別名保存の方法

    こんにちは。 Excelの素人です。blg.を参考に、ファイルの別名保存ボタンを作りましたが、別名保存後うまく終了してくれません。 現象は終了マクロから名前をつけて保存してもファイルが終了しません。もう一度ボタンをクリックするといきなり終了します。 素人の悲しさで、どこを修正すればよいのか悩んでいます。 Sub 別名保存後終了() If ThisWorkbook.Saved = False Then strFilename = ThisWorkbook.Path & "\" & _ "データ作成" & "_" & _ Format(Date, "yyyymmdd") & ".xls" strFilename = Application.GetSaveAsFilename( _ FileFilter:="Excelファイル,*.xls", _ InitialFileName:=strFilename, _ Title:="Excelファイルの保存") If strFilename = "False" Then If MsgBox("保存せずに終了します。よろしいですか？", _ vbOKCancel + vbInformation, _ "終了確認") = vbOK Then ThisWorkbook.Saved = True ThisWorkbook.Close Else Exit Sub End If Else ActiveWorkbook.SaveAs strFilename End If Else ThisWorkbook.Close End If End Sub 宜しくお願いします。

  • Excel2003VBAでファイルをコピーして指定場所に保存

    こんにちわ。 私は下記のコードで保存場所をＣドライブに指定しているのですが、これを保存先が選べるようにするのはどうすれば良いですか？ Application.DisplayAlerts = False Set OldWkbook = ActiveWorkbook ' 'ファイル名を取得 BkName1 = OldWkbook.Sheets(StName1).Range("E1").Value BkName2 = OldWkbook.Sheets(StName1).Range("E2").Value BkName3 = OldWkbook.Sheets(StName1).Range("E3").Value FileName = BkName1 & Format(".") & Format("試験結果") & Format(".") & BkName2 & Format(".") & BkName3 & ".xls" FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".xls" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If 'シートの保護を解除 Worksheets("Sheet1").Unprotect Worksheets("Sheet2").Unprotect Worksheets("Sheet3").Unprotect OldWkbook.Sheets(Array(StName1, StName2, StName3, StName4, StName5)).copy Set NewWkbook = ActiveWorkbook 'ボタンを削除 For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1 If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除 NewWkbook.Sheets(1).Shapes(wIx).Delete End If Next NewWkbook.Sheets(1).Name = StName1 'コピー先シートの保護 Sheets(1).Protect Sheets(2).Protect Sheets(3).Protect Sheets(4).Protect Sheets(5).Protect FileName = "C:\" & FileName If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then NewWkbook.Close savechanges:=False '##保存せずに終了 'シートの保護 Worksheets("Sheet1").Protect Worksheets("Sheet2").Protect Worksheets("Sheet3").Protect Exit Sub '##指定ファイル置き換え保存 End If NewWkbook.SaveAs FileName:=FileName Else '##ファイルを新規保存 NewWkbook.SaveAs FileName:=FileName End If NewWkbook.Close savechanges:=False Application.DisplayAlerts = True 'シートの保護 Worksheets("Sheet1").Protect Worksheets("Sheet2").Protect Worksheets("Sheet3").Protect End Sub

  • （VBA）特定のシートのみを名前を付けて保存

    Excel2003です。 数シートあるうちの特定のシートのみを別のbookとして「名前を付けて保存」する下記のコードを書きました。一応うまく動くのですが、実はこの特定のシートには行の非表示部分があります。しかし、下記のコードではもちろん非表示部分も開かれた状態で保存がされますよね。 この非表示の状態で保存するにはどのようにすればよいのでしょうか？ 【以下現在のコードです】 ------------------------------------------------ Sub 名前を付けて保存() '報告書を"名前を付けて保存" Sheets("報告書").Select Dim 既定ファイル名 As String Dim 保存ファイル名 As Variant 既定ファイル名 = "報告書" 保存ファイル名 = Application.GetSaveAsFilename(既定ファイル名, "Excel ブック(*.xls),*.xls") If 保存ファイル名 = False Then MsgBox "保存は中止されました。" Else With ThisWorkbook.ActiveSheet Workbooks.Add .Cells.Copy ActiveSheet.Range("A1") ActiveWorkbook.SaveAs 保存ファイル名, xlNormal ActiveWorkbook.Close False End With Sheets("報告書").Select Range("A1").Select MsgBox "報告書を作成しました。" End If End Sub ----------------------------------------------------

  • VBA　保存

    保存ボタンを作成してファイルに飛ぶように させていますが…どうしてもエラーになります！ エラー表示内容＞ 実行時エラー１００４ シートの名前を他のシート、Visual Basicで参照される オブジェクト　ライブラリまたは ワークシートと同じ名前に変更することはできません。 下記は実際の記述です。 Private Sub 保存_Click() Dim FileName As String Dim FileExt As String Dim BkName As String Dim OldWkbook As Workbook Dim NewWkbook As Workbook Const StName1 As String = "計画 グラフ" Const StName2 As String = "ケア一覧" ' Application.DisplayAlerts = False Set OldWkbook = ActiveWorkbook ' 'ファイル名を取得 BkName = OldWkbook.Sheets(StName1).Range("D1").Value FileName = BkName & Format(Now, "yyyy-mm-dd") & ".XLS" ' FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".XLS" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If ' OldWkbook.Sheets(Array(StName1, StName2)).Copy Set NewWkbook = ActiveWorkbook For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count NewWkbook.Sheets(1).Shapes(1).Delete '←シート1のボタンを削除 Next NewWkbook.Sheets(1).Name = StName1 NewWkbook.Sheets(2).Name = StName2 ' FileName = "D:\看護計画保存\" & FileName ' If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then NewWkbook.Close savechanges:=False '##保存せずに終了 Exit Sub End If '##指定ファイル置き換え保存 NewWkbook.SaveAs FileName:=FileName Else '##ファイルを新規保存 NewWkbook.SaveAs FileName:=FileName End If ' NewWkbook.Close savechanges:=False Application.DisplayAlerts = True End Sub

  • エクセル　VBA　シート保存ボタン

    Sheet上にボタンを作成 ボタンを押すと保存するようにしています！ 以前ここでSheet2枚をコピー出来るような 記述教えてもらったのですが・・ 1枚ならどう変化して良いか・・ 記述を書きましたが 何処が違うか教えて下さい！ Private Sub CommandButton1_Click() 　　Dim FileName　　As String 　　Dim FileExt　　 As String 　　Dim BkName　　　As String 　　Dim OldWkbook　 As Workbook 　　Dim NewWkbook　 As Workbook 　　Const StName1　 As String = "ko" 　　 　　' 　　Application.DisplayAlerts = False 　　Set OldWkbook = ActiveWorkbook 　　' 　　'ファイル名を取得 　　BkName = OldWkbook.Sheets(StName1).Range("A1").Value 　　FileName = BkName & Format(Now, "yyyy-mm") & ".XLS" 　　' 　　FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) 　　If FileName = "" Then 　　　　Exit Sub 　　Else 　　　　If Right(FileName, 4) <> ".XLS" Then 　　　　　　MsgBox "ファイル名が異常です。" 　　　　　　Exit Sub 　　　　End If 　　End If 　　' 　　OldWkbook.Sheets(Array(StName1)).Copy 　　Set NewWkbook = ActiveWorkbook 　　For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count 　　　　NewWkbook.Sheets(1).Shapes(wIx).Delete　 　　Next 　　NewWkbook.Sheets(1).Name = StName1 　　' 　　FileName = "D:\保存\計画\" & FileName 　　' 　　If Dir(FileName) <> "" Then 　　　　'##ファイルが既に存在する 　　　　If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then 　　　　　　NewWkbook.Close savechanges:=False 　　　　　　'##保存せずに終了 　　　　　　Exit Sub 　　　　End If 　　　　'##指定ファイル置き換え保存 　　　　NewWkbook.SaveAs FileName:=FileName 　　Else 　　　　'##ファイルを新規保存 　　　　NewWkbook.SaveAs FileName:=FileName 　　End If 　　' 　　NewWkbook.Close savechanges:=False 　　Application.DisplayAlerts = True End Sub 教えて下さい！

  • VBAでフォルダにあるエクセルファイルを開く

    こんにちは　このコードがうまく動かないのですが、 どこがいけないのかわからなく助けてください。 なおフォルダの中には******データ.xlsと言うファイルがあり、アスタリスク部分は日付が不規則に変化して上書きされるのです。 このファイルを開くマクロを作りたいのですが。 うまく行きません。 よろしくおねがいします。 Sub excelopen() ' ' Dim エクセル As String 'エクセル = Dir(ActiveWorkbook.Path & "\*データ.XLS") If エクセル = "" Then Exit Sub エクセル = ActiveWorkbook.Path & "\" & エクセル Workbooks.Open Filename:=エクセル End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する