エクセルのマクロで困っています。

PCに不自由な父が簡単に見積書を作れるようにエクセルで体裁を整えているのですが、自分で作成した「別名で保存する」ボタンを押した時に自動で「別名で保存」をさせたいのですが、どうにもうまく行きません。

具体的には、「A3:N3」のセルに見積もりの宛名が入っているので、「別名で保存」ボタン押下後、ファイル名を「<見積もりの宛名>様分<現在の年>年<現在の月>月<現在の日>日作成見積書.xls」として保存。
(ファイル名の例:「○○○○様分2008年2月10日作成見積書.xls」)

保存処理完了後、「<保存したファイル名>という名前でファイルを保存しました。」とダイアログを表示させたいのです。
なお、ファイルの保存先は現在のユーザーのデスクトップ配下「見積書フォルダ」に保存させたいと考えています。

エクセルのマクロに詳しい方、ぜひお知恵をお貸しください。よろしくお願いいたします。

回答の条件
  • 1人5回まで
  • 登録:2008/02/10 19:37:43
  • 終了:2008/02/11 09:51:14

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/02/10 20:31:03

ポイント45pt

こんな感じでご希望のようになるでしょうか。

'--- フォルダ名:後ろに "\" を付けてください
Const FolderName = "見積書フォルダ\"

Sub ボタン1_Click()
    Dim myDeskTopPath
'--- デスクトップパスの取得
    Set MyWSH = CreateObject("WScript.Shell")
    myDeskTopPath = MyWSH.SpecialFolders("Desktop") & "\"
    
    Dim fileName As String
'--- ファイル名の作成
    fileName = Range("A3").Value & "様分" & Format(Date, "YYYY年MM月DD日") & "作成見積書.xls"

'--- ファイルの保存
    ThisWorkbook.SaveAs myDeskTopPath & FolderName & fileName

'--- メッセージの表示
    MsgBox "<" & fileName & ">という名前でファイルを保存しました。"
End Sub
id:ga-ya

丁寧にありがとうざいました!

おかげさまでPCに不慣れな父も結構簡単に見積がつくれるようになりました!

2008/02/11 09:49:33

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/02/10 20:31:03ここでベストアンサー

ポイント45pt

こんな感じでご希望のようになるでしょうか。

'--- フォルダ名:後ろに "\" を付けてください
Const FolderName = "見積書フォルダ\"

Sub ボタン1_Click()
    Dim myDeskTopPath
'--- デスクトップパスの取得
    Set MyWSH = CreateObject("WScript.Shell")
    myDeskTopPath = MyWSH.SpecialFolders("Desktop") & "\"
    
    Dim fileName As String
'--- ファイル名の作成
    fileName = Range("A3").Value & "様分" & Format(Date, "YYYY年MM月DD日") & "作成見積書.xls"

'--- ファイルの保存
    ThisWorkbook.SaveAs myDeskTopPath & FolderName & fileName

'--- メッセージの表示
    MsgBox "<" & fileName & ">という名前でファイルを保存しました。"
End Sub
id:ga-ya

丁寧にありがとうざいました!

おかげさまでPCに不慣れな父も結構簡単に見積がつくれるようになりました!

2008/02/11 09:49:33
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692008/02/10 21:04:32

ポイント25pt

「A3:N3」のセルに見積もりの宛名という部分が、マージされたセルに1つ宛名があるのか、複数のセルに複数の宛名があるのかがわかりませんが。

1つのとき

Private Sub CommandButton1_Click()
    Dim MyWSH  As Object
    Dim myDeskTopPath As String
    Dim fname As String
    Dim r As Range
    
    'デスクトップのパスを取得する
    Set MyWSH = CreateObject("WScript.Shell")
    myDeskTopPath = MyWSH.SpecialFolders("Desktop")
    
    For Each r In Range("A3:N3")
        If r.Value <> "" Then
            'ファイルの名前を作成
            fname = r.Value & "様分" & Format(Now, "long date") & "作成見積書"
            
            '同名のファイルがあっても上書き保存する
            Application.DisplayAlerts = False
            
            'ブックの保存
            ActiveWorkbook.SaveAs myDeskTopPath & "\見積書\" & fname & ".xls"
            Application.DisplayAlerts = True
            
            'メッセージの表示
            MsgBox fname & "という名前でファイルを保存しました。"
        End If
    Next r
    Set MyWSH = Nothing
End Sub

複数のとき

Private Sub CommandButton1_Click()
   Dim MyWSH  As Object
    Dim myDeskTopPath As String
    Dim fname As String
    Dim r As Range
    
    'デスクトップのパスを取得する
    Set MyWSH = CreateObject("WScript.Shell")
    myDeskTopPath = MyWSH.SpecialFolders("Desktop")
    
    For Each r In Range("A3:N3")
        If r.Value <> "" Then
            'ファイルの名前を作成
            fname = r.Value & "様分" & Format(Now, "long date") & "作成見積書"
            
            '同名のファイルがあっても上書き保存する
            Application.DisplayAlerts = False
            
            'ブックの保存
            ActiveWorkbook.SaveAs myDeskTopPath & "\見積書\" & fname & ".xls"
            Application.DisplayAlerts = True
            
            'メッセージの表示
            MsgBox fname & "という名前でファイルを保存しました。"
        End If
    Next r
    Set MyWSH = Nothing
End Sub

注意 \を半角¥にしてください

id:ga-ya

SALINGERさんもありがとうございました。

おかげさまでぶじ解決しました!

2008/02/11 09:50:03
  • id:SALINGER
    間違って1つのときと複数のときが同じコードでした。
    1つのときのコードはほとんどMookさんと同じです。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません