エクセルマクロで教えて下さい

Question

いつもお世話になっております。
エクセルのマクロで入力した複数のセルからファイル名を取り込み保存とフォルダも同様に作成する仕組みでマクロをネットで探して組みました。マクロボタンで両方共作成出来るようにしたのですが、作成した際、フォルダに入る様にしたいのですが教えて頂けないでしょうか？

因みにマクロは下記の様に組んでます。
①セルの情報をファイル名にするマクロ
Sub セルをファイル名にするマクロ()

Application.Dialogs(xlDialogSaveAs).Show Arg1:=ActiveSheet.Range("K1").Text & ("_") & ActiveSheet.Range("P17") & ActiveSheet.Range("M3") & ("_") & ActiveSheet.Range("P11")


End Sub

②セルの情報をフォルダ名にするマクロ
Sub フォルダ作成()
Dim tDir As String 'フォルダ作成パス
Dim nDir As String '作成するフォルダ名

'このワークブックのパスを取得
tDir = ThisWorkbook.Path

'tDirに作成するフォルダ名(称:XXX)
nDir = tDir & "\" & Range("K1").Text & Range("M2") & Range("P17") & ("_") & Range("P11")

'既にnDirがあるかどうか確認
If Dir(nDir, vbDirectory) = "" Then
'ない場合は作る
MkDir nDir
'あるなら何もしない
Else: End If

End Sub

エクセルのファイル名とフォルダ名は基本的に同一ですが、一部分のみ違います。

VBAは①と②を合算してフォルダに入る様にするか、もしくは、作成したファイルを（Callを使って）フォルダに移動でも良いかと思うのですが・・・。

尚、保存するフォルダはエクセルを通常保存しているフォルダ内とします。
大元のフォルダ内にエクセルファイルと新規でフォルダを作成してその新規フォルダ内に最終的に保存したいです。

まだまだ、初めて日は浅いので①と②を作成が限界です。何卒宜しくお願い致します。

Qchan1962 · Accepted Answer

＃１です＞上記で作成致しましたフォルダに後から追加したエクセルファイル（マクロ有効で保存したいです）下記はSheets.Copyで新規ブックを作り保存していましたが、 Application.DisplayAlerts = False 'アラート抑制 Sheets.Copy 'マクロ無で保存のため、すべてのシートを新規ブックへ ActiveWorkbook.SaveAs _ 　　 fileName:=nDir & "\" & fname & ".xlsx" ActiveWorkbook.Close '保存したブックを閉じる Application.DisplayAlerts = True End Sub の部分を下記のようにします SaveCopyAsで行いコピーを別名で保存しています。 Dim Result, new_book As String new_book = nDir & "\" & fname & ".xlsm" If Dir(new_book) <> "" Then 　 Result = MsgBox("同名ファイルが存在します。" _ 　 & vbCrLf & "上書きしますか？", vbYesNo, "ブックの保存") 　 'Noを選択した時、保存せず終了　 If Result = vbNo Then 　　 MsgBox "終了します。" 　　 Exit Sub 　 End If End If ThisWorkbook.SaveCopyAs new_book '自ブックは保存、終了していません。 Application.DisplayAlertsに関しては、If Dir(new_book) <> "" Then 同名ファイルの存在を確認する事で無くすことが可能ですね、

Qchan1962 · Answer

こんにちは、

Application.Dialogsになっておりますが、保存する際に必要ですか？
必要が無いようなら、保存パス、ファイル名で保存することも出来ます
不明な点が、いくつかありますが、、
こんな感じかな、、

保存先パスを作成
フォルダ名を作成
ファイル名を作成
保存先パスにフォルダが無ければフォルダを作成
保存先パス＆フォルダ名にファイル名でファイルを保存

問題点
＞セルの情報をフォルダ、ファイル名にする場合、使用できない文字がある事
＞最終的に保存したいです
VBAで自ブックを保存する場合、マクロ有効で保存するか無効で保存するかでロジックが変わる事

最終的にDialogなどで確認して、実行するかを決めるか否か、、
と言う事で　Dialogを出しませんが、サンプルです。
コードに一応、コメントを付けました。
通常ブックで保存します。

Sub a()
Dim fname As String 'ファイル名
Dim folname As String 'フォルダ名
Dim folpath As String 'フォルダパス
Dim nDir As String '作成するフォルダ　パス＆名前
With ActiveSheet
　 'folname 作成するファイル名(称:XXX)
　 fname = _
　　　 .Range("K1").Text & _
　　　 ("_") & _
　　　 .Range("P17") & _
　　　 .Range("M3") & _
　　　 ("_") & _
　　　 .Range("P11")
　 'folname 作成するフォルダ名(称:XXX)
　 folname = _
　　　 .Range("K1").Text & _
　　　 .Range("M2") & _
　　　 .Range("P17") & _
　　　 ("_") & _
　　　 .Range("P11")
End With
'作成するフォルダパス
folpath = ThisWorkbook.Path 'マクロ実行ブックのパス

Dim UnAvailable, mg
'使えない文字をチェックする
For Each UnAvailable In Array("\", "/", ":", "*", "?", """", "<", ">", "|")
　 'バイナリで照合
　 If InStr(1, fname & folname, UnAvailable, vbBinaryCompare) > 0 Then
　　 '含まれていたら
　　 mg = mg & UnAvailable & vbCrLf
　 End If
Next
If mg <> "" Then 'チェック結果
　 MsgBox ("フォルダ・ファイル名に使えない文字 " & vbCrLf & mg & " が含まれています")
　 Exit Sub
Else
　 MsgBox ("Information" & vbCrLf & _
　　　 "対象フォルダパス：" & folpath & vbCrLf & _
　　　 "フォルダ名：" & folname & vbCrLf & _
　　　 "ファイル名：" & fname)
End If

nDir = folpath & "\" & folname
'既にnDirがあるかどうか確認
If Dir(nDir, vbDirectory) = "" Then
　 'ない場合は作る
　 MkDir nDir
Else 'あるなら
End If

'名前を付けて保存（新規ブック、マクロ無（拡張子.xlsx）
Application.DisplayAlerts = False 'アラート抑制
Sheets.Copy 'マクロ無で保存のため、すべてのシートを新規ブックへ
ActiveWorkbook.SaveAs _
　　 fileName:=nDir & "\" & fname & ".xlsx"
ActiveWorkbook.Close '保存したブックを閉じる
Application.DisplayAlerts = True
End Sub

少々違いますが、Dialogを出す場合、プロパティにパスやファイル名、拡張子など設定すれば良いかと思います。

エクセル マクロで教えて下さい

＃１です

こんにちは、

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

エクセルマクロで教えて下さい