Excel VBA ファイル名・シート名・保存先変更ツールコード crossfish21

コード

※昔に書いた、穴だらけコード

Option Explicit
Option Base 1

Dim objFSO As FileSystemObject         ' FSO
Dim wb As Workbook                     ' ワークブック　汎用
Dim ws As Worksheet                    ' ワークシート　汎用
Dim bolFind As Boolean                 ' フラグ用

Dim wsMenu As Worksheet                ' 「メニュー」シート
Dim wsIchiran As Worksheet             ' 「一覧」シート
Dim outputGyou As Long                 ' 出力する行番号
Dim lastGyou As Long                   ' データのある最終行
Dim errorFileList() As String          ' エラーで開くことが出来なかったファイルのフルパスを格納する配列
Dim lngCellColor As Long               ' セルの色の設定値
Dim wbKoushinList As Workbook          ' 更新リストのファイル
Dim wsKoushinList As Worksheet         ' 更新リストのシート
Dim koushinListGyou As Long            ' 更新リストのシートで、現在対象となっている行番号
Dim wbNewFile As Workbook              ' 新ファイル
Dim strOldFileName As String           ' 旧ファイルのファイル名
Dim strNewFileName As String           ' 新ファイルのファイル名
Dim strOldSheetName As String          ' 旧シート名
Dim strNewSheetName As String          ' 新シート名
Dim strOldFilePath As String           ' コピー元のファイルパス
Dim strNewHozonPath As String          ' 新保存先パス
Dim strReigaiPath As String            ' 例外時の保存先パス
Dim reigaiFileNumber As Long           ' ファイル名の例外に関する通し番号
Dim reigaiSheetNumber As Long          ' シート名の例外に関する通し番号
Dim strKakuchoushi As String           ' 新ファイル名に拡張子が無い場合の、付与する拡張子の文字列　「メニュー」シートで設定

Const cellColorNumber_1 As Long = 10092543    ' セル色1
Const cellColorNumber_2 As Long = 13434777    ' セル色2
Const reigaijiColorNumber As Long = 10040319  ' 例外時のセルの色
Const maxRetsu As Long = 17                   ' データが入る最大列番号
Const pathRetsu As Long = 2                      ' 一覧シートの「パス」列の列番号
Const fileNameRetsu As Long = 3                  ' 一覧シートの「ファイル名」列の列番号
Const sheetNameRetsu As Long = 4                 ' 一覧シートの「シート名」列の列番号
Const newHozonPathRetsu As Long = 6              ' 一覧シートの「新保存先パス」列の列番号
Const newFileNameRetsu As Long = 7               ' 一覧シートの「新ファイル名」列の列番号
Const newSheetNameRetsu As Long = 8              ' 一覧シートの「新シート名」列の列番号
Const jikkouRetsu As Long = 9                    ' 一覧シートの「実行」列の列番号
Const jissaiHozonPathRetsu As Long = 11          ' 一覧シートの「実際の保存先パス」列の列番号
Const jissaiFilePathRetsu As Long = 12           ' 一覧シートの「実際のファイルパス」列の列番号
Const jissaiFileNamehRetsu As Long = 13          ' 一覧シートの「実際のファイル名」列の列番号
Const jissaiSheetNamehRetsu As Long = 14         ' 一覧シートの「実際のシート名」列の列番号
Const problemHozonRetsu As Long = 15             ' 一覧シートの「保存先の問題発生」列の列番号
Const problemFileNameRetsu As Long = 16          ' 一覧シートの「ファイル名の問題発生」列の列番号
Const problemSheetNameRetsu As Long = 17         ' 一覧シートの「シート名の問題発生」列の列番号



Sub MakeIchiran()  ' ファイル名・シート名一覧作成処理

    Dim strStartPath As String            ' ファイル名・シート名一覧作成の基点となるフォルダのパス
    Dim i As Long
    
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set wsMenu = ThisWorkbook.Worksheets("メニュー")
    
    If objFSO.FolderExists(wsMenu.Cells(4, 2).Value) = False Then
        MsgBox "検索対象フォルダとして指定されたフォルダは存在しません"
        Exit Sub
    Else
        strStartPath = wsMenu.Cells(4, 2).Value
        If Right(strStartPath, 1) <> "\" Then  ' パスの最後に￥が無い場合は、￥を付け足す
            strStartPath = strStartPath & "\"
            wsMenu.Cells(4, 2).Value = wsMenu.Cells(4, 2).Value & "\"
        End If
    End If
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Worksheets("一覧（コピー元）").Visible = True  ' 隠しシートを再表示
    Worksheets("一覧（コピー元）").Copy After:=Worksheets("メニュー")
    Set wsIchiran = ActiveSheet
    Worksheets("一覧（コピー元）").Visible = False  ' シートを非表示に戻す
    wsIchiran.Name = "一覧"
    
    outputGyou = 2
    lngCellColor = cellColorNumber_1
    Erase errorFileList
    ReDim Preserve errorFileList(1)
    
    Call FileSheetSearch(strStartPath)  ' ファイル名・シート名検索処理を呼び出し
    
    wsIchiran.Activate
    lastGyou = wsIchiran.Cells(wsIchiran.Rows.Count, sheetNameRetsu).End(xlUp).Row  ' 最終行取得
    
    If lastGyou > 1 Then  ' 有効なデータがある場合
        wsIchiran.Range(Cells(2, pathRetsu), Cells(lastGyou, maxRetsu)).Borders.LineStyle = True  ' 罫線設定
        
        For i = 2 To lastGyou
            If wsIchiran.Cells(i, pathRetsu).Value <> "" Then
                wsIchiran.Hyperlinks.Add Anchor:=Cells(i, pathRetsu), Address:=Cells(i, pathRetsu)  ' パスにハイパーリンク付与
            End If
        Next i
    End If
    
    If errorFileList(1) <> "" Then  ' エラーで開けなかったファイルがある場合
    
        outputGyou = lastGyou + 3 ' リストの最終行の３行下から、エラーで開けなかったファイルのフルパスを出力
        wsIchiran.Cells(outputGyou, 2).Value = "エラーで開くことの出来なかったファイル"
        outputGyou = outputGyou + 1
        
        For i = 1 To UBound(errorFileList) - 1  ' エラーのあったファイルのリストの配列の内容を出力
            wsIchiran.Cells(outputGyou, 2).Value = errorFileList(i)
            outputGyou = outputGyou + 1
        Next i
        
        MsgBox "エラーが発生して開くことの出来なかったファイルがあります。リストの最下段下部を参照してください"
    
    End If
    
    wsIchiran.Move
    wsMenu.Cells(8, 2).Value = ActiveWorkbook.Name & ".xlsx"
    
    Set objFSO = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "完了"

End Sub


Sub Change_FileName_SHeetName_SaveFolder()  ' ファイル名・シート名・保存先変更処理
    

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set wsMenu = ThisWorkbook.Worksheets("メニュー")
    
    ' 例外時の保存先フォルダのチェック
    If objFSO.FolderExists(wsMenu.Cells(12, 2).Value) = False Then
        MsgBox "例外時の保存先フォルダとして指定されたフォルダは存在しません"
        Exit Sub
    Else
        strReigaiPath = wsMenu.Cells(12, 2).Value
        If Right(strReigaiPath, 1) <> "\" Then  ' パスの最後に￥が無い場合は、￥を付け足す
            strReigaiPath = strReigaiPath & "\"
            wsMenu.Cells(12, 2).Value = wsMenu.Cells(12, 2).Value & "\"
        End If
    End If
    
    
    ' 更新リストファイルのチェック
    bolFind = False
    For Each wb In Workbooks
        If wb.Name = wsMenu.Cells(8, 2).Value Then
            Set wbKoushinList = wb
            bolFind = True
            Exit For
        End If
    Next wb
    If bolFind = False Then   ' 更新リストファイルが現在開かれていない場合
        MsgBox "更新リストファイルとして指定されているファイルが開かれていません"
        Exit Sub
    End If
    
    bolFind = False
    For Each ws In wbKoushinList.Sheets
        If ws.Name = "一覧" Then
            Set wsKoushinList = ws
            bolFind = True
            Exit For
        End If
    Next ws
    If bolFind = False Then   ' 更新リストファイルに「一覧」シートが存在しない場合
        MsgBox "更新リストファイル内に「一覧」シートが存在しません"
        Exit Sub
    End If
    
    If wsKoushinList.Cells(1, pathRetsu).Value <> "パス" Or wsKoushinList.Cells(1, problemSheetNameRetsu).Value <> "シート名の問題発生" Then
    ' 本来のフォーマットと違う場合
        MsgBox "「一覧」シートのフォーマットが変更されています。行や列の追加・削除はしないでください"
        Exit Sub
    End If
    
    ' 新ファイルの拡張子設定
    If ThisWorkbook.Worksheets("メニュー").OpXlsx.Value = True Then
        strKakuchoushi = ".xlsx"
    Else
        strKakuchoushi = ".xls"
    End If
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    wsKoushinList.Activate
    If wsKoushinList.AutoFilterMode = True Then  ' フィルタが設定されている場合
        If wsKoushinList.AutoFilter.FilterMode = True Then  ' フィルタで絞込みがされている場合
            wsKoushinList.ShowAllData  ' フィルタを解除しておく
        End If
    End If
    lastGyou = wsKoushinList.Cells(wsKoushinList.Rows.Count, sheetNameRetsu).End(xlUp).Row  ' 更新リストシートのデータのある最終行を求める
    
    If lastGyou < 2 Then  ' 一覧のデータが全く無い場合、処理を中止する
        Set objFSO = Nothing
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        MsgBox "一覧のデータが全くありませんでした"
        Exit Sub
    End If
    
    wsKoushinList.Range(Cells(2, jissaiHozonPathRetsu), Cells(lastGyou, problemSheetNameRetsu)).Value = "－"
    ' "－"で初期化しておく
    
    Call Check_MakeFolder   ' 指定された保存先フォルダの存在確認と新規フォルダ作成の処理を呼び出し
    
    ' 例外に関する通し番号初期化
    reigaiFileNumber = 1
    reigaiSheetNumber = 1
    
    koushinListGyou = 2
    Do While koushinListGyou <= lastGyou ' ファイル名・シート名・保存先変更処理
    
        With wsKoushinList
    
            If .Cells(koushinListGyou, jikkouRetsu).Value <> "○" Then   ' 「実行」列に「○」が入っていなければ、そのファイルは対象外
                koushinListGyou = koushinListGyou + 1
                Do While .Cells(koushinListGyou, fileNameRetsu).Value = ""  ' 次のコピー元ファイルの範囲へ入るまで
                    koushinListGyou = koushinListGyou + 1
                    If koushinListGyou > lastGyou Then   ' 最終行まで来ていたら、ループを抜ける
                        Exit Do
                    End If
                Loop
                
            Else  ' 実行対象である場合
        
                strOldFilePath = .Cells(koushinListGyou, pathRetsu).Value
                If objFSO.FileExists(strOldFilePath) = False Then  ' コピー元のファイルが存在しない場合
                    .Range(Cells(koushinListGyou, problemHozonRetsu), Cells(koushinListGyou, problemSheetNameRetsu)).Value = "コピー元のファイルが存在しません"
                    ' 「保存先の問題発生」列～「シート名の問題発生」列
                    .Range(Cells(koushinListGyou, problemHozonRetsu), Cells(koushinListGyou, problemSheetNameRetsu)).Interior.Color = reigaijiColorNumber
                    ' 「保存先の問題発生」列～「シート名の問題発生」列のセル色を例外時の色へ
                    koushinListGyou = koushinListGyou + 1
                    Do While .Cells(koushinListGyou, fileNameRetsu).Value = ""  ' 次のコピー元ファイルの範囲へ入るまで
                        .Cells(koushinListGyou, jissaiSheetNamehRetsu).Value = "－"    ' 「実際のシート名」列
                        .Cells(koushinListGyou, problemSheetNameRetsu).Value = "コピー元のファイルが存在しません"  ' 「シート名の問題発生」列
                        .Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
                        koushinListGyou = koushinListGyou + 1
                        If koushinListGyou > lastGyou Then   ' 最終行まで来ていたら、ループを抜ける
                            Exit Do
                        End If
                    Loop
                    
                Else  ' コピー元のファイルが存在する場合、通常のファイル名･シート名・保存先変更メイン処理を呼び出し
                
                    If Dir(strOldFilePath) = ThisWorkbook.Name Then
                    ' このツールと同じファイル名のファイルは開かないようにする
                        .Cells(koushinListGyou, problemFileNameRetsu).Value = "コピー元のファイルパスのファイル名がこのツールと同じだったので、このファイルは処理をしません"
                        .Cells(koushinListGyou, problemSheetNameRetsu).Value = "コピー元のファイルパスのファイル名がこのツールと同じだったので、このファイルは処理をしません"
                        .Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
                        .Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
                        koushinListGyou = koushinListGyou + 1
                        Do While .Cells(koushinListGyou, fileNameRetsu).Value = ""  ' 次のコピー元ファイルの範囲へ入るまで
                            .Cells(koushinListGyou, problemSheetNameRetsu).Value = "コピー元のファイルパスのファイル名がこのツールと同じだったので、このファイルは処理をしません"  ' 「シート名の問題発生」列
                            .Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
                            koushinListGyou = koushinListGyou + 1
                            If koushinListGyou > lastGyou Then   ' 最終行まで来ていたら、ループを抜ける
                                Exit Do
                            End If
                        Loop
                        
                    Else ' 通常処理
                        Call Koushin_Normal
                    End If
                
                End If
                
            End If
            
        End With
        
    Loop
    
    ' 実際の保存先パスと実際のファイルパス列にハイパーリンクを付与
    koushinListGyou = 2
    Do While koushinListGyou <= lastGyou
        With wsKoushinList
            If .Cells(koushinListGyou, jissaiHozonPathRetsu).Value <> "－" Then
                .Hyperlinks.Add Anchor:=.Cells(koushinListGyou, jissaiHozonPathRetsu), Address:=.Cells(koushinListGyou, jissaiHozonPathRetsu).Value
            End If
            If .Cells(koushinListGyou, jissaiFilePathRetsu).Value <> "－" Then
                .Hyperlinks.Add Anchor:=.Cells(koushinListGyou, jissaiFilePathRetsu), Address:=.Cells(koushinListGyou, jissaiFilePathRetsu).Value
            End If
        End With
    
        koushinListGyou = koushinListGyou + 1
    Loop
    
    
    Set objFSO = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "完了"


End Sub


Sub Koushin_Normal()  ' 通常のファイル名･シート名・保存先変更メイン処理

    Dim nextFileStartGyou As Long              ' 次のファイルの開始行

    With wsKoushinList
    
        ' 新しい保存先に関する処理
        If .Cells(koushinListGyou, newHozonPathRetsu).Value = "" Then  ' 新保存先パスがブランクの場合は、例外時保存先を指定する
            strNewHozonPath = strReigaiPath
            .Cells(koushinListGyou, jissaiHozonPathRetsu).Value = strNewHozonPath
            .Cells(koushinListGyou, problemHozonRetsu).Value = "新しい保存先の指定が無いため、例外時の保存先に格納しました"
            .Cells(koushinListGyou, problemHozonRetsu).Interior.Color = reigaijiColorNumber
        Else  ' 新しい保存先の指定がある場合
            strNewHozonPath = .Cells(koushinListGyou, newHozonPathRetsu).Value
            If Right(strNewHozonPath, 1) <> "\" Then '新保存先パスの最後に「￥」が無い場合は付与する
                strNewHozonPath = strNewHozonPath & "\"
            End If
            
            If objFSO.FolderExists(strNewHozonPath) = False Then   ' 新しい保存先のフォルダが存在しない場合
                strNewHozonPath = strReigaiPath
                .Cells(koushinListGyou, jissaiHozonPathRetsu).Value = strNewHozonPath
                .Cells(koushinListGyou, problemHozonRetsu).Value = "新しい保存先のフォルダが存在しないため、例外時の保存先に格納しました"
                .Cells(koushinListGyou, problemHozonRetsu).Interior.Color = reigaijiColorNumber
            Else   ' 新しい保存先のフォルダが存在する場合
                ' 何もしない
            End If
        End If
        
        
        ' 新ファイル名に関する処理
        strNewFileName = .Cells(koushinListGyou, newFileNameRetsu).Value
        If strNewFileName = "" Then  ' 新ファイル名の指定が無い場合
            strNewFileName = .Cells(koushinListGyou, fileNameRetsu).Value
            
        Else   ' 新ファイル名の指定がある場合
            If InStr(strNewFileName, ".xls") > 0 Then ' 新ファイル名に拡張子が含まれている場合
                ' 何もしない　strNewFileNameはそのまま使用
            Else ' 新ファイル名に拡張子が含まれていない場合は、拡張子を付与する
                If ThisWorkbook.Worksheets("メニュー").OpXlsx.Value = True Then
                    strNewFileName = strNewFileName & strKakuchoushi
                Else
                    strNewFileName = strNewFileName & strKakuchoushi
                End If
            End If
            
        End If
        
        
        If objFSO.FileExists(strNewHozonPath & strNewFileName) = True Then  ' 保存先に既に新ファイル名と同名ファイルがある場合
            strNewFileName = "例外ファイル名_" & reigaiFileNumber & strKakuchoushi    ' ファイル名を例外用のものへ
            .Cells(koushinListGyou, problemFileNameRetsu).Value = "新しい保存先に同名のファイルがあるため、例外時のファイル名にしました"
            .Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
            
            Do While objFSO.FileExists(strNewHozonPath & strNewFileName) = True
            ' 新保存先に同じファイル名のファイルがある可能性があるので､重複がなくなるまでreigaiFileNumberをカウントアップする
                reigaiFileNumber = reigaiFileNumber + 1
                strNewFileName = "例外ファイル名_" & reigaiFileNumber & strKakuchoushi
            Loop
            reigaiFileNumber = reigaiFileNumber + 1
        End If
        
        
        ' コピー元ファイルを開き、名前を付けて保存で一旦保存しておく
        On Error GoTo ErrorHandler_1
        Workbooks.Open Filename:=strOldFilePath, ReadOnly:=True, UpdateLinks:=0
        ' 新ファイルを読み取り専用、リンク更新なしで開く
        On Error GoTo 0
        Set wbNewFile = ActiveWorkbook
        
        On Error GoTo ErrorHandler_3
        If Right(strNewFileName, 5) = ".xlsx" Then ' 新ファイル名の末尾が「.xlsx」の場合
            wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlOpenXMLWorkbook
        ElseIf Right(strNewFileName, 4) = ".xls" Then ' 新ファイル名の末尾が「.xls」の場合
            wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlExcel8
        ElseIf Right(strNewFileName, 5) = ".xlsm" Then ' 新ファイル名の末尾が「.xlsm」の場合
            wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        Else  ' 使用できない新ファイル名が指定されている場合
            strNewFileName = "例外ファイル名_" & reigaiFileNumber & strKakuchoushi  ' ファイル名を例外用のものへ
            .Cells(koushinListGyou, problemFileNameRetsu).Value = "新ファイル名の拡張子が「.xlsx」「.xls」「.xlsm」以外であるため、例外時のファイル名にしました"
            .Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
            
            Do While objFSO.FileExists(strNewHozonPath & strNewFileName) = True
            ' 新保存先に同じファイル名のファイルがある可能性があるので､重複がなくなるまでreigaiFileNumberをカウントアップする
                reigaiFileNumber = reigaiFileNumber + 1
                strNewFileName = "例外ファイル名_" & reigaiFileNumber & strKakuchoushi
            Loop
            reigaiFileNumber = reigaiFileNumber + 1
        
            If strKakuchoushi = ".xlsx" Then
                wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlOpenXMLWorkbook
            Else
                wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlExcel8
            End If

        End If
        On Error GoTo 0
            
        

        ' 新ファイルの実際の保存先、実際のファイル名、実際のシート名を入力
        .Cells(koushinListGyou, jissaiHozonPathRetsu).Value = strNewHozonPath
        .Cells(koushinListGyou, jissaiFilePathRetsu).Value = strNewHozonPath & strNewFileName
        .Cells(koushinListGyou, jissaiFileNamehRetsu).Value = strNewFileName
        
        If koushinListGyou >= lastGyou Then  ' データのある最終行まで既に到達していた場合
            nextFileStartGyou = koushinListGyou + 1
        Else
            nextFileStartGyou = koushinListGyou + 1
            Do While .Cells(nextFileStartGyou, fileNameRetsu).Value = ""  ' 次のファイルの範囲に入るまで、nextFileStartGyouをカウントアップ
                nextFileStartGyou = nextFileStartGyou + 1
                If nextFileStartGyou > lastGyou Then   ' 最終行まで来ていたら、ループを抜ける
                    Exit Do
                End If
            Loop
        End If
        
        Do While koushinListGyou < nextFileStartGyou
            strOldSheetName = .Cells(koushinListGyou, sheetNameRetsu).Value
            strNewSheetName = .Cells(koushinListGyou, newSheetNameRetsu).Value
            If strNewSheetName = "" Then  ' 新シート名がブランクの場合は、旧シート名を新シート名とする
                strNewSheetName = strOldSheetName
            End If
            
            bolFind = False
            For Each ws In wbNewFile.Worksheets  ' 新ファイルのシートに、旧シート名が存在することのチェック
                If ws.Name = strOldSheetName Then
                
ReturnFromError_2:
                    On Error GoTo ErrorHandler_2
                    ws.Name = strNewSheetName
                    .Cells(koushinListGyou, jissaiSheetNamehRetsu).Value = strNewSheetName
                    .Cells(koushinListGyou, jissaiFilePathRetsu).Value = strNewHozonPath & strNewFileName   ' 「実際のファイルパス」列にも入力しておく
                    On Error GoTo 0
                    bolFind = True
                    Exit For
                End If
            Next ws
            If bolFind = False Then  ' 新ファイルのシートに、旧シート名が存在しない場合
                .Cells(koushinListGyou, problemSheetNameRetsu).Value = "旧シート名のシートが新ファイルに存在しないので、シート名の変更はしませんでした"
                .Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
                .Cells(koushinListGyou, jissaiFilePathRetsu).Value = strNewHozonPath & strNewFileName   ' 「実際のファイルパス」列にも入力しておく
            End If
                
            koushinListGyou = koushinListGyou + 1
        Loop
        
ReturnFromError_3:

        wbNewFile.Close SaveChanges:=True  ' ファイルを閉じる
        
ReturnFromError_1:
                
    End With
    
    Exit Sub
    

' 以下、エラー時処理
    
ErrorHandler_1:  ' コピー元ファイルを開く時にエラーが発生した場合の処理
    
    wsKoushinList.Cells(koushinListGyou, problemFileNameRetsu).Value = "何らかの理由により、コピー元ファイルオープン時にエラー発生"
    wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、コピー元ファイルオープン時にエラー発生"
    wsKoushinList.Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
    wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
    koushinListGyou = koushinListGyou + 1
    Do While wsKoushinList.Cells(koushinListGyou, fileNameRetsu).Value = ""  ' 次のコピー元ファイルの範囲へ入るまで
        wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、コピー元ファイルオープン時にエラー発生"  ' 「シート名の問題発生」列
        wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
        koushinListGyou = koushinListGyou + 1
        If koushinListGyou > lastGyou Then   ' 最終行まで来ていたら、ループを抜ける
            Exit Do
        End If
    Loop
    
    Resume ReturnFromError_1
    
    
ErrorHandler_2:  ' シート名変更時にエラーが発生した場合の処理
    
    strNewSheetName = "例外時のシート名_" & reigaiSheetNumber
    reigaiSheetNumber = reigaiSheetNumber + 1
    wsKoushinList.Cells(koushinListGyou, jissaiSheetNamehRetsu).Value = strNewSheetName
    wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、シート名変更時にエラーが発生（シート名の重複が考えられます）ため、シート名は例外時のものとしました"
    wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
    wsKoushinList.Cells(koushinListGyou, jissaiFilePathRetsu).Value = strNewHozonPath & strNewFileName   ' 「実際のファイルパス」列にも入力しておく
    
    Resume ReturnFromError_2
    

ErrorHandler_3:  ' 新ファイル保存時にエラーが発生した場合の処理
    
    wsKoushinList.Cells(koushinListGyou, problemFileNameRetsu).Value = "何らかの理由により、新ファイル保存時にエラー発生"
    wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、新ファイル保存時にエラー発生"
    wsKoushinList.Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
    wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
    koushinListGyou = koushinListGyou + 1
    Do While wsKoushinList.Cells(koushinListGyou, fileNameRetsu).Value = ""  ' 次のコピー元ファイルの範囲へ入るまで
        wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、新ファイル保存時にエラー発生"  ' 「シート名の問題発生」列
        wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
        koushinListGyou = koushinListGyou + 1
        If koushinListGyou > lastGyou Then   ' 最終行まで来ていたら、ループを抜ける
            Exit Do
        End If
    Loop
    
    Resume ReturnFromError_3

End Sub


Sub Check_MakeFolder()  ' 指定された保存先フォルダの存在確認と新規フォルダ作成

    Dim objFolder As Object             ' フォルダ
    Dim pathBunkatsu() As String        ' パスを「￥」区切りで分割し、格納する配列
    Dim strPath As String
    Dim lastPath As String
    Dim currentGyou As Long             ' 現在検索中の行数
    Dim i As Long
    
    
    For currentGyou = 2 To lastGyou
    
        If wsKoushinList.Cells(currentGyou, fileNameRetsu).Value <> "" And wsKoushinList.Cells(currentGyou, newHozonPathRetsu).Value <> "" Then
        ' 「ファイル名」列に値があり、かつ「新保存先パス」列に値がある場合
            strPath = wsKoushinList.Cells(currentGyou, newHozonPathRetsu).Value
            Erase pathBunkatsu
            ReDim Preserve pathBunkatsu(1)
            
            ' パスの文字列を「￥」区切りで後ろ側から分解していく
            On Error GoTo ErrorHandler
            Do While Dir(strPath, vbDirectory) = ""
                pathBunkatsu(UBound(pathBunkatsu)) = Mid(strPath, (InStrRev(strPath, "\")), (Len(strPath) - (InStrRev(strPath, "\")) + 1))
                ReDim Preserve pathBunkatsu(UBound(pathBunkatsu) + 1)
                strPath = Mid(strPath, 1, (InStrRev(strPath, "\") - 1))
                If Dir(strPath, vbDirectory) <> "" Then
                    lastPath = strPath
                    Exit Do
                End If
            Loop
            On Error GoTo 0
            
            i = UBound(pathBunkatsu) - 1
            Do While i > 0
                lastPath = lastPath & pathBunkatsu(i)
                MkDir (lastPath)   ' フォルダ作成
                i = i - 1
            Loop
            
        End If
        
ReturnFromError:
        
    Next currentGyou
    
    
    Erase pathBunkatsu
    
    Exit Sub
    
ErrorHandler:
    ' 特に何もせず、ReturnFromErrorまで戻る
    Resume ReturnFromError

End Sub


Sub FileSheetSearch(strStartPath As String)  ' フォルダ内のファイル名・シート名の取得（再帰処理でサブフォルダも）

    Dim objFile As Object           ' ファイル
    Dim objFolder As Object         ' フォルダ
    Dim objSubFolder As Object      ' サブフォルダ
    Dim wbTarget As Workbook        ' 検索対象のファイル
    Dim lngWsCount As Long          ' シートのカウント用変数
    
    With objFSO
    
        Set objFolder = .GetFolder(strStartPath)

        ' フォルダ内のファイルのデータを出力
        For Each objFile In objFolder.Files
        
            If .GetFile(objFile).Name Like "*.xlsx" Or _
                .GetFile(objFile).Name Like "*.xls" Or _
                .GetFile(objFile).Name Like "*.xlsm" Then
            ' .xlsx .xls .xlsm のエクセルファイルだった場合
            
                If .GetFile(objFile).Name = ThisWorkbook.Name Then
                ' 自分自身と同じ名前のファイルだった場合は、開かずにエラー扱いとする
                    errorFileList(UBound(errorFileList)) = objFSO.GetFile(objFile).Path
                    ReDim Preserve errorFileList(UBound(errorFileList) + 1)
                Else
                    On Error GoTo ErrorHandler  ' ファイルが開けなかった場合は、ErrorHandlerへ
                    
                    Workbooks.Open Filename:=.GetFile(objFile).Path, ReadOnly:=True, UpdateLinks:=0
                    ' ファイルを読み取り専用で開く
                    On Error GoTo 0
                    Set wbTarget = ActiveWorkbook
                    
                    wsIchiran.Activate
                    wsIchiran.Cells(outputGyou, pathRetsu).Value = .GetFile(objFile).Path
                    wsIchiran.Cells(outputGyou, fileNameRetsu).Value = wbTarget.Name
                    wsIchiran.Cells(outputGyou, jikkouRetsu).Value = "○"
                    wsIchiran.Range(Cells(outputGyou, pathRetsu), Cells(outputGyou, maxRetsu)).Interior.Color = lngCellColor
    
                    lngWsCount = 1
                    For Each ws In wbTarget.Sheets   ' 全シートを出力
                        wsIchiran.Cells(outputGyou, sheetNameRetsu).Value = ws.Name
                        If lngWsCount > 1 Then
                        ' ２シート目以降は「新保存先パス」・「新ファイル名」・「実行」列に「****」を入力　セル色も設定
                            wsIchiran.Cells(outputGyou, newHozonPathRetsu).Value = "****"
                            wsIchiran.Cells(outputGyou, newFileNameRetsu).Value = "****"
                            wsIchiran.Cells(outputGyou, jikkouRetsu).Value = "****"
                            wsIchiran.Range(Cells(outputGyou, pathRetsu), Cells(outputGyou, maxRetsu)).Interior.Color = lngCellColor
                        End If
                        outputGyou = outputGyou + 1
                        lngWsCount = lngWsCount + 1
                    Next ws
                    
                    If lngCellColor = cellColorNumber_1 Then  ' セル色の入れ替え
                        lngCellColor = cellColorNumber_2
                    Else
                        lngCellColor = cellColorNumber_1
                    End If
                    
                    wbTarget.Close SaveChanges:=False
                    
                End If
                
            End If
            
ReturnFromError:
        Next objFile
        
        ' 再帰処理でサブフォルダのデータを出力する
        For Each objSubFolder In objFolder.SubFolders
        
            Call FileSheetSearch(objSubFolder.Path)  ' ここで自分自身を呼び出す再帰処理
            
        Next objSubFolder
    
    End With
    
    Exit Sub
    
ErrorHandler:  ' エラーでファイルが開けなかった場合の処理

    errorFileList(UBound(errorFileList)) = objFSO.GetFile(objFile).Path  ' エラーのファイルリストに追加
    ReDim Preserve errorFileList(UBound(errorFileList) + 1)
    
    Resume ReturnFromError

End Sub


Sub SelectFolder_Ichiran()  ' 一覧作成の開始フォルダを選択するダイアログを開く

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Cells(4, 2).Value = .SelectedItems(1) & "\"
        Else
            MsgBox "キャンセルされました"
        End If
    End With
    
End Sub


Sub SelectFolder_Reigai()  ' 例外時の保存フォルダを選択するダイアログを開く

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Cells(12, 2).Value = .SelectedItems(1) & "\"
        Else
            MsgBox "キャンセルされました"
        End If
    End With
    
End Sub


Sub KoushinListFileSelect()  ' 更新リストのファイルを選択するフォームを開く

    Load FormFileSelect
    
    ' 現在開いているファイルをフォームのリストに追加
    For Each wb In Workbooks
        If wb.Name <> ThisWorkbook.Name Then  ' 自分自身はリストに入れない
            FormFileSelect.ListFileName.AddItem wb.Name
        End If
    Next wb
    
    FormFileSelect.Show
    
End Sub