Excelで任意のセルのデータをファイル名に追加して上書き保存するマクロ

質問

Excelのブックが300個ほどあります。
現在アルファベット4文字のファイル名がついています。
このブックを1つずつ開き、任意のセル（ブックごとに異なる）を選択後ホットキーでマクロを起動し選択したセルの内容をもともとのファイル名に追加して名前を付けて保存したいのです。

例）
元のファイル名：bgf.xls
選んだセル：A4
A4の内容：あいうえお
新しく保存するファイル名：あいうえおbgf.xls

環境はwin2k、Excel2kです
よろしくお願いします。

回答No.2

Wendy02 · ベストアンサー

こんにちは。

ホットキーで？

あまり、きちんとしたチェックをしたわけではありませんが、対話型で作るなら、以下のようになりますね。

Sub RenameFiles()
　 Dim FileName As Variant
　 Dim BaseFName As String
　 Dim myPathName As String
　 Dim NewFileName As String
　 Dim fn As Variant
　 Dim rng As Variant

　 FileName = Application.GetOpenFilename("Excel(*.xls),*.xls", MultiSelect:=True)
　 If VarType(FileName) = vbBoolean Then Exit Sub
　 For Each fn In FileName
　　　On Error Resume Next
　　　Set rng = Application.InputBox(fn & vbCrLf & _
　　　"の名前の変更をします。" & vbCrLf & "セルを選択してください。", "ファイル名変更", "$A$4", Type:=8)
　　　On Error GoTo 0
　　　If VarType(rng) = vbEmpty Or rng Is Nothing Then Exit Sub

　　　If IsEmpty(rng.Value) Then
　　　　 MsgBox "セルが空です。", vbCritical
　　　　 Else
　　　　 BaseFName = Mid$(fn, InStrRev(fn, "\") + 1)
　　　　 myPathName = Mid$(fn, 1, InStrRev(fn, "\"))
　　　　 NewFileName = myPathName & rng.Value & BaseFName
　　　　 If Dir(NewFileName) = "" Then
　　　　　　On Error GoTo ErrHandler
　　　　　　If MsgBox(NewFileName & vbCrLf & " に変更してよろしいですか？", vbOKCancel) = vbOK Then
　　　　　　　 Name fn As NewFileName
　　　　　　　 MsgBox "変更しました。", vbInformation
　　　　　　End If
　　　　　　Else
　　　　　　MsgBox "同名ファイルがあります。", vbCritical
　　　　 End If
　　　End If
　　　Set rng = Nothing
　　　Next fn
　　　Exit Sub
ErrHandler:
　　　MsgBox Err.Number & ":" & Err.Description
　　　Resume Next
End Sub

お礼

ありがとうございます。
御礼が遅くなりすみません。
教えていただいたマクロを少し加工して期待した動作するようになりました。

回答No.1

noname#15459

SendKeys Sheets("Sheet1").Range("A4").Value
Application.Dialogs(xlDialogSaveAs).Show

お礼

ありがとうございます。
ちょっと期待していたものとはちがいましたが今後の参考にさせていただきます。