[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダまたはファイル名の変更』(りん)
フォルダの中に
フォルダまたはファイルがたくさんあります
このフォルダまたはファイル名を一括で変更したいです
変更内容は先頭にある「日付」を最後にもっていき
アンダーバーを調整することです
(現行フォルダまたはファイル名)
日付_コード_コード_コード_会社名
(変更後のフォルダまたはファイル名)
コード_コード_コード_会社名_日付
今はひとつづつ変更してます
< 使用 Excel:Microsoft365、使用 OS:Windows10 >
手持ちの道具↓を流用するなら... という「やっつけ仕事」的な案ですけど ^^;
なので >フォルダまたはファイル フォルダの方は考えてないです。
' 1.A列にファイル名を列挙して、 ' 2.B列に変更後のファイル名を自分で書き込み、 ' 3.ボタンからまとめて変換実行 ' という流れのものです。 Sub ファイル選択() Dim aFolder As Object, aFile As Object Dim aPath As String, WkSh As Worksheet, r As Long On Error Resume Next With Application.FileDialog(msoFileDialogFolderPicker) .Show aPath = .SelectedItems(1) End With On Error GoTo 0 If aPath = "" Then Exit Sub If ActiveWorkbook Is Nothing Then Workbooks.Add If ActiveWorkbook.Path <> "" Or Not ActiveWorkbook.Saved Then Workbooks.Add Set WkSh = ActiveSheet WkSh.Range("A:A").NumberFormat = "@" WkSh.Cells(1, 1).Value = aPath WkSh.Cells(3, 1).Value = "元ファイル名" WkSh.Cells(3, 2).Value = "ReName to" WkSh.Cells(3, 3).Value = "変換結果" With WkSh.Range("A3:C3") .Borders(xlEdgeBottom).LineStyle = xlContinuous .AutoFilter End With Set aFolder = CreateObject("Scripting.FileSystemObject").GetFolder(aPath) If aFolder.Files.Count = 0 Then MsgBox "No Files", vbExclamation Exit Sub End If r = 3 For Each aFile In aFolder.Files r = r + 1 Cells(r, 1).Value = aFile.Name Next aFile WkSh.Columns(1).AutoFit WkSh.Columns(2).ColumnWidth = WkSh.Columns(1).ColumnWidth WkSh.Cells(4, 1).Select ActiveWindow.FreezePanes = True With WkSh.Range("C1:C2") With WkSh.Buttons.Add(.Left, .Height * 1 / 3 / 2, .Width, .Height * 2 / 3) .OnAction = "ExecuteFileReName" .Caption = "変換実行" End With End With End Sub Private Sub ExecuteFileReName() Dim Fsys As Object, aFolder As Object, aFile As Object Dim aPath As String, r As Long, aExte As String, c As Long Dim AFRows As Range aPath = Cells(1, 1).Value With ActiveSheet.AutoFilter.Range Set AFRows = .Offset(1).Resize(.Rows.Count) End With If MsgBox("実行する?", vbOKCancel + vbExclamation) = vbCancel Then Exit Sub With CreateObject("Scripting.FileSystemObject") Set aFolder = .GetFolder(aPath) For Each aFile In aFolder.Files For r = 1 To AFRows.Rows.Count If Len(AFRows(r, 2).Value) = 0 Then ElseIf aFile.Name = AFRows(r, 1).Value And AFRows(r, 1).Value <> AFRows(r, 2).Value Then aExte = .GetExtensionName(aFile.Path) If aExte <> "" And Not AFRows(r, 2).Value Like "*.*" Then AFRows(r, 2).Value = AFRows(r, 2).Value & "." & aExte If .FileExists(aPath & "\" & AFRows(r, 2).Value) Then AFRows(r, 3).Value = "既存ファイル名" Else aFile.Name = AFRows(r, 2).Value AFRows(r, 3).Value = aFile.Name c = c + 1 End If Exit For End If Next Next End With MsgBox c & "件を変換", vbInformation End Sub
で...
_||____________________A____________________|____________________B____________________|___C____|___D____|_____E_____|_______________F________________| 1|| | | | | | | 2||YYYYMMDD_コード_コード_コード_会社名.xlsx|コード_コード_コード_会社名_YYYYMMDD.xlsx| | 9|YYYYMMDD |コード_コード_コード_会社名.xlsx| 3|| | | | | | |
D2 =FIND("_",A2) E2 =LEFT(A2,D2-1) F2 =MID(A2,D2+1,LEN(A2)) B2 =SUBSTITUTE(F2,".","_"&E2&".")
(白茶) 2023/03/17(金) 10:35:46
私は最近 PowerToys をインストールしてPowerRename を使ってます https://learn.microsoft.com/ja-jp/windows/powertoys/powerrename
正規表現も使えるので1....使いこなせてないですが、便利です (´・ω・`) 2023/03/17(金) 11:19:51
Sub test() Dim fdg As FileDialog, p As String Dim plcy As String, cmd As String
Set fdg = Application.FileDialog(msoFileDialogFolderPicker) If Not fdg.Show Then Exit Sub
p = "'" & fdg.SelectedItems(1) & "\20[0-2][0-9][0-1][0-9][0-3][0-9]_*_*_*_*'" plcy = "-ExecutionPolicy RemoteSigned" cmd = "Get-ChildItem " & p & " | " & _ "ForEach-Object { " & _ "$a = $_.BaseName.Split('_', 2)" & ";" & _ "$p = Split-Path $_.FullName" & ";" & _ "Rename-Item $_.FullName ($p + '\' + $a[1] + '_' + $a[0] + $_.Extension)}" CreateObject("wscript.shell").Run "powershell " & plcy & " -Command " & cmd, 0, True
End Sub
(マナ) 2023/03/18(土) 20:42:18
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.