新規ファイルをデスクトップに「yymmdd-hhmm.xlsx」という名前で保存するだけの処理です。名前とかいいからとにかく保存しとく、という用途です。
- VBA自体は PERSONAL.xlsx に保存しておき、リボンのユーザ設定でボタンを割り当てておくのが便利かなと思います。
- アクティブになってるファイルに対して動作します。
- 新規じゃないファイルで動かしたときは上書き保存する動作にしています。
Sub とりあえずデスクトップに保存()
Dim FSO As Object 'ファイルシステムオブジェクト
Dim WSH As Variant 'WSH(Windows Scripting Host)
Dim DefaultPath As String
Dim strOutputFileName As String
Dim strDate As String
Const strExtName As String = "xlsx"
Dim i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
DefaultPath = WSH.SpecialFolders("Desktop") & "\" 'デスクトップ。"\"まで入れる。
'新規ファイルかどうかを判断（一度も保存してなければ Path が空白）
If ActiveWorkbook.Path = "" Then
Else
'保存したことがあるファイルは上書き保存
ActiveWorkbook.Save
MsgBox "上書きしました。" & vbCrLf & vbCrLf & _
ActiveWorkbook.Path & "\" & ActiveWorkbook.Name, vbInformation + vbOKOnly, "上書き"
Exit Sub
End If
'--------------------------------------
'デスクトップに保存
'--------------------------------------
strDate = Format(Now(), "yymmdd-hhmm")
strOutputFileName = strDate
i = 0
Do
If FSO.FileExists(DefaultPath & "\" & strOutputFileName & "." & strExtName) = False Then
Exit Do
Else
'ファイル名
i = i + 1
strOutputFileName = strDate & "_" & i
End If
Loop
'ファイルを保存
ActiveWorkbook.SaveAs Filename:=DefaultPath & strOutputFileName & "." & strExtName
MsgBox "保存しました。" & vbCrLf & vbCrLf & _
ActiveWorkbook.Path & "\" & ActiveWorkbook.Name, vbInformation + vbOKOnly, "名前をつけて保存"
End Sub
