同一フォルダ内に格納されているファイルを、毎回
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ベストアンサー
- 回答日時:
#1です
ひょっとして、早とちりしましたか、、、
>現状は、単に同一フォルダ内の複数ファイルを取り込むだけの内容になっています。これらの動作の前に、名称変更できたら有り難いです。
フォルダ内のファイル名をリネームしたいと言う事でしょうか?
リネームは、連番などを付ける事が多いけれど、数値削除となると、より一層同名等のエラー発生の可能性が高まりますね。
こちらを参考に 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 などの場合)
ファイルのリネームなので、簡単な検証はしました。
ありがとうございます!まさに、フォルダ内のリネームに関する質問でした。
質問内容が伝わりづらくて、申し訳ございません。
同名になる可能性は、やはりどうしても残ってしまいますよね。。
その可能性を念頭に置きながら使用していくようにします。
夕方にまとまった時間が取れるので、教えていただいた記述を加えて、
検証してみたいと思います。ひとまず、お礼にて。
No.1
- 回答日時:
こんにちは、
数値の部分をなくせば良いのでしょうか?
そのようにして同名シートは出来ないかと、、少し心配ですが
数値部分をなくしたシート名にするとして
ご質問のコードの変更を最小にする場合、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
追加コード(1行)
SheetName = Dir(Filename)
' [[ ファイル名で新しいシート作成 ]]
'この下に
SheetName=RE_Num(SheetName) ’追加
Set NewWorkSheet = CreateWorkSheet(SheetName)’既存そのまま
検証はしていませんので、コピーファイルで検証してください。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・14歳の自分に衝撃の事実を告げてください
- ・架空の映画のネタバレレビュー
- ・「お昼の放送」の思い出
- ・昨日見た夢を教えて下さい
- ・ちょっと先の未来クイズ第4問
- ・【大喜利】【投稿~10/21(月)】買ったばかりの自転車を分解してひと言
- ・メモのコツを教えてください!
- ・CDの保有枚数を教えてください
- ・ホテルを選ぶとき、これだけは譲れない条件TOP3は?
- ・家・車以外で、人生で一番奮発した買い物
- ・人生最悪の忘れ物
- ・【コナン30周年】嘘でしょ!?と思った○○周年を教えて【ハルヒ20周年】
- ・ハマっている「お菓子」を教えて!
- ・最近、いつ泣きましたか?
- ・夏が終わったと感じる瞬間って、どんな時?
- ・10秒目をつむったら…
- ・人生のプチ美学を教えてください!!
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・都道府県穴埋めゲーム
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルVBAでセルに入力したパ...
-
excelに貼り付けた数値が勝手に...
-
EXCELのVBAで画像を選んだ順に...
-
Teraマクロで日付ディレクトリ...
-
ファイルを並び替えるときの「...
-
エクセルを選択して開き印刷す...
-
VLOOKUP関数とネットワークに置...
-
Excelvbaで同一フォルダー内の...
-
CSVで文字化けしてしまうのを直...
-
VBAでFileDialogを利用してファ...
-
ミュージックファイルのファイ...
-
エクセル 一括リンクの解除
-
ハイパーリンクで前回値をひき...
-
検索結果をテキスト吐き出し
-
ローマ字→カタカナへ変換(エク...
-
マクロ 実行ボタンを押さずに...
-
押したボタンの位置取得(共通の...
-
コマンドボタンを押すたびに大...
-
Excel:コマンドボタンの移動
-
Excelを開いた時に表示さ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルVBAでセルに入力したパ...
-
excelに貼り付けた数値が勝手に...
-
EXCELのVBAで画像を選んだ順に...
-
Teraマクロで日付ディレクトリ...
-
ハイパーリンクで前回値をひき...
-
エディタで効率的な切り出し方法
-
ファイルを並び替えるときの「...
-
CSVで文字化けしてしまうのを直...
-
excel INDIRECT 他ファイル参照
-
VLOOKUP関数とネットワークに置...
-
Excelvbaで同一フォルダー内の...
-
エクセル 一括リンクの解除
-
エクセルVBA+ADOで特定のCSVフ...
-
エクセルVBAで指定フォルダ内の...
-
=CELL("filename")で取得したフ...
-
【マクロ】2回実行したら、エ...
-
CDBurnerXP「ファイル名が長す...
-
EXCEL VBA ー 同一フォルダ内の...
-
PDF ファイルが開けません。
-
複数のcsvファイルの結合
おすすめ情報