Excelを快適に使おう

'---------------------------------------------------------------------------------------------------
'
' マクロ: フォルダにあるファイル名を取得または変更します
'
'---------------------------------------------------------------------------------------------------
Option Explicit

'---------------------------------------------------------------------------------------------------
' 概要：フォルダにあるファイル一覧を取得します(サブフォルダ内含む)
' 補足：ファイル数の上限は65535です(Transpose)
'---------------------------------------------------------------------------------------------------
Sub getFileList()

    'ダイアログを使って取得したいファイル一覧のあるフォルダを指定します
    Dim dRes As FileDialog
    
    Set dRes = Application.FileDialog(msoFileDialogFolderPicker)
    
    If dRes.Show = False Then
        MsgBox "キャンセルしました"
        Exit Sub
    End If
    
    
    'フォルダ内のファイル一覧を取得します(再帰)
    Dim fDirs() As String
    Dim fFiles() As String
    
    ReDim fDirs(0)
    ReDim fFiles(0)
    
    Call searchFile(dRes.SelectedItems(1), fDirs, fFiles)

    'A列にパス、B列にファイル名を記載します
    Range("A1").Resize(UBound(fDirs) + 1, 1) = WorksheetFunction.Transpose(fDirs)
    Range("B1").Resize(UBound(fFiles) + 1, 1) = WorksheetFunction.Transpose(fFiles)
    Range("A1") = "【フォルダパス】"
    Range("B1") = "【変更前ファイル名】"
    Range("C1") = "【変更後ファイル名】"
    Range("D1") = "【ステータス】"

End Sub

'---------------------------------------------------------------------------------------------------
' 概要　：フォルダにあるファイル一覧を取得します(現在のフォルダ)
' 補足１：再帰使ってます。メモリ消費します
' 補足２：fDirs, fFilesの配列要素0は空で、1から値が入ります。配列要素最後も冗長です
'---------------------------------------------------------------------------------------------------
Private Sub searchFile(Path As String, fDirs() As String, fFiles() As String)

    'フォルダ内のファイルを取得
    Dim getFiles As String
    
    getFiles = Dir(Path & "\*.*")
    
    Do While getFiles <> ""
        ReDim Preserve fDirs(UBound(fDirs) + 1)
        ReDim Preserve fFiles(UBound(fFiles) + 1)
        
        fDirs(UBound(fDirs)) = Path
        fFiles(UBound(fFiles)) = getFiles

        getFiles = Dir()
    Loop
    
    
    'サブフォルダがあったら自身を呼び出す
    Dim fSystem As Object
    
    With CreateObject("Scripting.FileSystemObject")
        For Each fSystem In .GetFolder(Path).subFolders
            Call searchFile(fSystem.Path, fDirs, fFiles)
        Next fSystem
    End With

End Sub

'---------------------------------------------------------------------------------------------------
' 概要　：フォルダにあるファイルを変更します(サブフォルダ内含む)
' 機能　：A列のフォルダパスにあるB列のファイル名を、C列のファイル名に変更します
' 補足１：C列に記載がなければ無視します
' 補足２：ファイル名重複対策で制限があります。__TEMP__が先頭のファイル名は無いものとしてます
'---------------------------------------------------------------------------------------------------
Sub chgFileList()

    '変更がなければ処理を終了します
    Dim rowLast As Long

    rowLast = Cells(Rows.Count, 3).End(xlUp).row
    If rowLast <= 1 Then
        Exit Sub
    End If

    'D列のステータスをクリア
    Range("D2").Resize(rowLast, 1) = ""


    'フォルダ内で変更後のファイル名がかぶるのは問題なので止めます
    Dim row As Long
    Dim fHash As Object
    Dim fullPath As String
    
    Set fHash = CreateObject("Scripting.Dictionary")
    
    For row = 1 To rowLast
        If Len(Cells(row, 3)) > 0 Then
            fullPath = Cells(row, 1) & "\" & Cells(row, 3)
            If fHash.Exists(fullPath) Then
                MsgBox "変更後のファイル名が重複してます " & vbCrLf & _
                       Cells(row, 3).Address(False, False) & " セル" & vbCrLf & "ファイル名は変更しません"
                Exit Sub
            Else
                fHash.Add fullPath, 0
            End If
        End If
    Next row

    'ファイル名を変更します。変更前のファイル名とかぶる場合は一旦一時ファイルを作り、後で変えます
    Dim preFile As String
    Dim postFile As String
    Dim tempFiles() As String
    Const tempHeader As String = "__TEMP__"
    
    ReDim tempFiles(0)
    
    For row = 2 To rowLast
        preFile = Cells(row, 1) & "\" & Cells(row, 2)
        postFile = Cells(row, 1) & "\" & Cells(row, 3)

        If existFile(preFile) = False Then
            Cells(row, 4) = "× 変更前ファイルがありません"
        ElseIf Cells(row, 2) = Cells(row, 3) Then
            Cells(row, 4) = "× 変更前後のファイル名が同じです"
        ElseIf Len(Cells(row, 3)) > 0 Then
            
            '変更前ファイルがある場合の対策
            If existFile(postFile) Then
                
                ReDim Preserve tempFiles(UBound(tempFiles) + 1)
                
                postFile = Cells(row, 1) & "\" & tempHeader & Cells(row, 3)
                tempFiles(UBound(tempFiles)) = postFile

                '制限：__TEMP__が先頭のファイル名があると置き換え拒否
                If existFile(postFile) Then
                    MsgBox "ファイル名先頭に「" & tempHeader & "」があり置き換えできないです" & vbCrLf _
                           & "" & Cells(row, 2).Value & " はファイル名変更しません"
                    Cells(row, 4) = "× 変更しません"
                End If

            End If
        
            'ファイル名変更
            If changeFileName(preFile, postFile) = False Then
                Cells(row, 4) = "× 変更できませんでした"
            End If
        End If
    Next row


    '一時ファイルを変更
    Dim i As Long
    Dim fPath As String
    Dim fName As String
    
    For i = 1 To UBound(tempFiles)
        fName = Right(tempFiles(i), Len(tempFiles(i)) - InStrRev(tempFiles(i), "\"))
        fPath = Left(tempFiles(i), Len(tempFiles(i)) - Len(fName) - 1)
        fName = Right(tempFiles(i), Len(fName) - Len(tempHeader))

        preFile = tempFiles(i)
        postFile = fPath & "\" & fName
        If changeFileName(preFile, postFile) = False Then
            MsgBox fName & "は、ファイル名の変更ができませんでした" & vbCrLf _
                   & "" & tempHeader & fName & "ファイルに変更しています"
        End If
    Next i
    
End Sub

'---------------------------------------------------------------------------------------------------
' 概要　：ファイルが存在するか確認します
'
'---------------------------------------------------------------------------------------------------
Private Function existFile(fName As String) As Boolean
    Dim chkFile As Boolean
    
    chkFile = False
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(fName) Then
            chkFile = True
        Else
            chkFile = False
        End If
    End With
    
    existFile = chkFile
End Function

'---------------------------------------------------------------------------------------------------
' 概要　：ファイルを変更します
'
'---------------------------------------------------------------------------------------------------
Private Function changeFileName(preFile As String, postFile As String) As Boolean
    
    On Error GoTo chgError
    
    Name preFile As postFile

    changeFileName = True
    Exit Function

chgError:
    changeFileName = False
End Function