[[20230317094847]]　『フォルダまたはファイル名の変更』（りん）　ページの最後に飛ぶ

『フォルダまたはファイル名の変更』（りん）

フォルダの中に
フォルダまたはファイルがたくさんあります

このフォルダまたはファイル名を一括で変更したいです
変更内容は先頭にある「日付」を最後にもっていき
アンダーバーを調整することです

（現行フォルダまたはファイル名）
　日付_コード_コード_コード_会社名

（変更後のフォルダまたはファイル名）
　コード_コード_コード_会社名_日付

今はひとつづつ変更してます

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

 手持ちの道具↓を流用するなら... という「やっつけ仕事」的な案ですけど　^^;

 なので
 >フォルダまたはファイル
 フォルダの方は考えてないです。

    ' １．A列にファイル名を列挙して、
    ' ２．B列に変更後のファイル名を自分で書き込み、
    ' ３．ボタンからまとめて変換実行
    ' という流れのものです｡
    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

コメント返信：

[ 一覧(最新更新順) ]

[[20230317094847]] 『フォルダまたはファイル名の変更』（りん） ページの最後に飛ぶ

[[20230317094847]]　『フォルダまたはファイル名の変更』（りん）　ページの最後に飛ぶ