Excel CSVファイル セル名を名前として保存

質問

いつもありがとうございます。エクセル２００３XPです。
毎回USBメモリーに上書きされてくる、同名のCSVファイルを別エクセルファイルに読み込む作業をしております。

その作業は外部データの読み込みを記憶マクロとして問題ないのですが、エクセルに読み込んだCSVファイルは、かぶらないようにそのつど、Kill を使い削除しております。
ただ完全に削除なので対策として、
読み込んだCSVファイルの１行目のセル名をファイル名として名前を変えて保存、
PCの"C:\Documents and Settings\元データ に毎回CSVもしくは、エクセルファイルに名前を変更して保存する処理をボタンひとつで出来ないか、考えております。

ネットで色々と検索をしておりますが、勉強不足です。
参考でサンプルマクロは見つけましたが、どのように変更すれば良いか分かりません。ご享受いただければ助かります。

CSVファイル名 ： log001.csv(毎回、USB)
保存したいファイル名 ： CSVファイルを開いた時のA１のセル名（日付です）
保存場所 ： PCのマイドキュメントの元データファイル
保存したいファイル形式 ： CSVもしくはExcelファイル

Sub THSFILE_SAVE()

Dim myFname0 As String
Dim myFname As String
On Error GoTo ERRH
'現在のファイル名取得
myFname0 = ThisWorkbook.Name
'新しいファイル名をセルA1の値とする
myFname = Sheets(1).Range("A1").Value
'同じ階層に保存
ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & myFname
If myFname0 <> myFname & ".xls" Then
'前の名前のファイルを削除する場合は下の一行を有効にしてください
'Kill ThisWorkbook.Path & "\" & myFname0
End If
Exit Sub
ERRH:
End Sub

この処理はCSVファイルの読み込み先のエクセルファイルから、行いたいと考えております。
よろしくお願致します。

回答No.2

Wendy02

本来、WScript で十分だと思います。それをデスクトップに置けばよいのですが、わざわざ、VBAにしたところで、どこかのブックに置かなくてはなりません。以下のマクロの登録先は、PERSONAL.XLS や一般のブックに登録することになります。

Kill ThisWorkbook.Path & "\" & myFname0
もとのマクロですが、ThisWorkbookというのは変ですね。
以下は、log数字.csv なら通るようにしてあります。

'//
Sub CsvConvertFile()
　Dim FName As String
　Dim oFName As String
　Dim oFullName As String
　Dim oName As String
　Dim sPath As String
　Dim sExt As String
　Dim i As Long
　sExt = IIf(Val(Application.Version) > 11, ".xlsx", ".xls")
　'デフォルトパス
　sPath = Application.DefaultFilePath
　oFName = ActiveWorkbook.Name
　oFullName = ActiveWorkbook.FullName
　If Not StrConv(oFName, vbLowerCase) Like "log###*" Then MsgBox "Logファイルではありません。", 16: Exit Sub
　If InStrRev(oFName, ".csv", , 1) = 0 Then MsgBox "csvファイルではありません。", 16: Exit Sub
　If ActiveSheet.Range("A1").Value = "" Then
　　MsgBox "A1に文字がありません。", vbCritical
　　Exit Sub
　End If
　FName = ActiveSheet.Range("A1").Value
　'同名ファイルがあった場合に名前を変更
　oName = FName
　Do
　　If Dir(sPath & FName & sExt) <> "" Then
　　　i = i + 1
　　　FName = oName & Format(i, "(0)") '重複があった時のファイル名
　　End If
　Loop Until Dir(sPath & FName & sExt) = ""
　ActiveWorkbook.SaveAs sPath & FName, FileFormat:=xlWorkbookNormal
　If MsgBox(oFName & "を削除してよろしいですか？", vbOKCancel) = vbOK Then
　　Kill oFullName
　End If
End Sub

回答No.1

kybo

以下の様にしてはどうでしょうか？

Sub THSFILE_SAVE()
Dim myFname0 As String
Dim myFname As String
myFname0 = Workbooks("log001.csv").FullName
myFname = Workbooks("log001.csv").Sheets(1).Range("A1").Value
'実行しているブックと同じパスにCSVファイルのコピーを保存
Workbooks("log001.csv").SaveCopyAs ThisWorkbook.Path & "\" & myFname & ".csv"
'CSVファイルを保存しないで閉じる
Workbooks("log001.csv").Close False
'削除
Kill myFname0
End Sub