EXCEL VBA ー 同一フォルダ内のCSVファイル名を変更

同一フォルダ内に格納されているファイルを、毎回
aaa.csv
bbb.csv
ccc.csv
ccd.csv
という名前でシートとしてExcelファイルに取り込みたいのですが、
システムから同じ種類のファイルをダウンロードしてくると、
aaa1.csv
bbb3.csv
のように、ダウンロード回数が後ろについたり、
ccc20210406.csv
ccd20210406.csv
のように、物によってはダウンロード日付がついて保存されてしまいます。

これを毎回手動で不要部分削除していたのですが、
マクロによって取り込みたい形に変更するにはどのように記述したら良いか
教えていただけないでしょうか。

ファイル名から数字部分を消すという設定にすれば、全ファイルに対応出来そうです。
お力を貸していただきたく、お願い申し上げます。

--------------------
現状は、単に同一フォルダ内の複数ファイルを取り込むだけの内容になっています。
これらの動作の前に、名称変更できたら有り難いです。

' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
' [[ ]]
' [[ 複数CSVファイル読込 ]]
' [[ ]]
' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]

' [[ 変数定義 ]]
Dim varFileName As Variant
Dim CSVWorkSheet As Worksheet
Dim NewWorkSheet As Worksheet
Dim SheetName As String
Dim Filename As Variant

' [[ コピー範囲の変数 ]]
Dim R1 As Integer
Dim R2 As Long
Dim C1 As Integer
Dim C2 As Integer

' [[ 複数ファイルパス名を取得 ]]
varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
Title:="CSVファイルの選択", MultiSelect:=True)

' [[ ファイルパス取得できなかったら ]]
If IsArray(varFileName) = False Then
Exit Sub
End If

' [[ ファイルパス取得できたら ]]
For Each Filename In varFileName
' [[ ファイルパスからファイル名を取得 ]]
SheetName = Dir(Filename)
' [[ ファイル名で新しいシート作成 ]]
Set NewWorkSheet = CreateWorkSheet(SheetName)

' [[ CSVファイルを開く ]]
Workbooks.Open Filename:=Filename
Set CSVWorkSheet = ActiveSheet

' [[ 有効セルの範囲取得 ]]
R1 = CSVWorkSheet.UsedRange.Row
C1 = CSVWorkSheet.UsedRange.Column
R2 = CSVWorkSheet.UsedRange.End(xlDown).Row
C2 = CSVWorkSheet.UsedRange.End(xlToRight).Column

' [[ 有効セルの範囲のコピー ]]
CSVWorkSheet.UsedRange.Copy Destination:=NewWorkSheet.Range(NewWorkSheet.Cells(R1, C1), NewWorkSheet.Cells(R2, C2))

' [[ CSVファイルを閉じる(保存無し) ]]
ActiveWorkbook.Close SaveChanges:=False
Next

Application.ScreenUpdating = True

End Sub

' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
' [[ ]]
' [[ ワークシート名を指定したワークシートの作成 ]]
' [[ ]]
' [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
Function CreateWorkSheet(WorkSheetName As String) As Worksheet

' 変数定義
Dim NewWorkSheet As Worksheet
Dim iCheckSameName As Integer
Dim WS As Worksheet

Application.ScreenUpdating = False

' ワークシートの作成
' ※一番最後に挿入
Set NewWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))

' 同じ名前ワークシートが無いか確認
iCheckSameName = 0
For Each WS In Sheets
If WS.Name = WorkSheetName Then
MsgBox "ワークシート名：" + WorkSheetName + " この名前は既に使われています。"
iCheckSameName = 1
End If
Next

'同じ名前のワークシートがなければ
If iCheckSameName = 0 Then
NewWorkSheet.Name = WorkSheetName
Set CreateWorkSheet = NewWorkSheet
End If

Sheets("program").Select

Application.ScreenUpdating = False

End Function

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2021/04/06 19:33

＃１です

ひょっとして、早とちりしましたか、、、
＞現状は、単に同一フォルダ内の複数ファイルを取り込むだけの内容になっています。これらの動作の前に、名称変更できたら有り難いです。

フォルダ内のファイル名をリネームしたいと言う事でしょうか？

リネームは、連番などを付ける事が多いけれど、数値削除となると、より一層同名等のエラー発生の可能性が高まりますね。

こちらを参考に　http://officetanaka.net/excel/vba/tips/tips56.htm
書き換えてみました。

フォルダ内のファイルすべてのファイル名をリネーム（数値部分を削除）します。CSVファイルが対象です。

Sub Files_reName_NumDel()
　Dim path As String, fso, file, files
　Dim reMatch, reValue
　With Application.FileDialog(msoFileDialogFolderPicker)
　 　If .Show = True Then
　 　 　path = .SelectedItems(1)
　 　End If
　End With
　If path = "" Then Exit Sub
　Set fso = CreateObject("Scripting.FileSystemObject")
　Set files = fso.GetFolder(path).files
　For Each file In files
　 　If LCase(fso.GetExtensionName(file)) = "csv" Then
　 　 　With CreateObject("VBScript.RegExp")
　 　 　 　.Pattern = "\d+"
　 　 　 　.Global = True
　 　 　 　Set reMatch = .Execute(file.Name)
　 　 　 　If reMatch.Count > 0 Then
　 　 　 　 　For Each reValue In reMatch
　 　 　 　 　 　On Error Resume Next
　 　 　 　 　 　file.Name = Replace(file.Name, reValue, "")
　 　 　 　 　Next reValue
　 　 　 　End If
　 　 　End With
　 　End If
　Next file
End Sub

同名になる場合は、数値削除せずに次に進みます。
（一部の数値が残る可能性があり、違うファイルが既存ファイル名になる可能性があります。a1 a10 a12 などの場合）

ファイルのリネームなので、簡単な検証はしました。

この回答へのお礼

ありがとうございます！まさに、フォルダ内のリネームに関する質問でした。
質問内容が伝わりづらくて、申し訳ございません。
同名になる可能性は、やはりどうしても残ってしまいますよね。。
その可能性を念頭に置きながら使用していくようにします。
夕方にまとまった時間が取れるので、教えていただいた記述を加えて、
検証してみたいと思います。ひとまず、お礼にて。

お礼日時：2021/04/07 11:14

No.1 回答者： Qchan1962 回答日時： 2021/04/06 18:10

こんにちは、

数値の部分をなくせば良いのでしょうか？
そのようにして同名シートは出来ないかと、、少し心配ですが
数値部分をなくしたシート名にするとして
ご質問のコードの変更を最小にする場合、Functionを追加するのが、手っ取り早いかと思います。
追加 Function
Function RE_Num(strTxt As String)
With CreateObject("VBScript.RegExp")
.Pattern = "([0-9]+)"
.Global = True
RE_Num = .Replace(strTxt, "")
End With
End Function

追加コード（１行）
SheetName = Dir(Filename)
' [[ ファイル名で新しいシート作成 ]]
'この下に
SheetName=RE_Num(SheetName)　’追加
Set NewWorkSheet = CreateWorkSheet(SheetName)’既存そのまま

検証はしていませんので、コピーファイルで検証してください。