エクセルファイル分割マクロ

Option Explicit

' メイン処理
Sub ProcessAllExcelFilesInFolder()
    Dim fso As Object
    Dim folderPath As String
    Dim fileList As Collection
    Dim filePath As Variant
    Dim logLines As Collection
    Dim logPath As String

    Set fileList = New Collection
    Set logLines = New Collection
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' ユーザーにフォルダを選ばせる
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "処理するフォルダを選択してください"
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1)
    End With

    ' 対象ファイル収集（拡張対応済）
    Call CollectExcelFiles(fso.GetFolder(folderPath), fileList)

    ' 各ファイルを処理
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each filePath In fileList
        ProcessSingleWorkbook CStr(filePath), logLines
    Next filePath

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    ' ログを出力
    logPath = folderPath & "\log_" & Format(Now, "yyyymmdd_HHMMSS") & ".csv"
    WriteLog logLines, logPath

    MsgBox "完了しました。" & vbCrLf & "ログファイル: " & logPath, vbInformation
End Sub

' 対象ファイルを再帰的に取得（.xlsx, .xlsm, .xls）
Sub CollectExcelFiles(folder As Object, fileList As Collection)
    Dim file As Object
    Dim subFolder As Object
    Dim ext As String

    For Each file In folder.Files
        ext = LCase(fso.GetExtensionName(file.Name))
        If ext = "xlsx" Or ext = "xlsm" Or ext = "xls" Then
            fileList.Add file.Path
        End If
    Next file

    For Each subFolder In folder.SubFolders
        CollectExcelFiles subFolder, fileList
    Next subFolder
End Sub

' 個別ファイル処理
Sub ProcessSingleWorkbook(filePath As String, logLines As Collection)
    Dim srcBook As Workbook
    Dim shObj As Worksheet
    Dim newBook As Workbook
    Dim newBookName As String
    Dim folderParent As String
    Dim safeSheetName As String, safeValue As String
    Dim savePath As String
    Dim logEntry As String

    On Error GoTo ErrHandler

    If filePath = ThisWorkbook.FullName Then Exit Sub
    Set srcBook = Workbooks.Open(filePath, ReadOnly:=True)
    folderParent = fso.GetParentFolderName(filePath) & "\"

    For Each shObj In srcBook.Worksheets
        shObj.Copy
        Set newBook = ActiveWorkbook

        safeValue = Replace(Replace(Trim(newBook.Sheets(1).Range("A1").Text), "\", "_"), "/", "_")
        If safeValue = "" Then safeValue = "NoTitle"
        safeSheetName = Replace(shObj.Name, "\", "_")

        newBookName = safeValue & "_" & safeSheetName & ".xlsx"
        savePath = GenerateUniqueFileName(folderParent, newBookName)

        newBook.SaveAs savePath
        newBook.Close SaveChanges:=False

        logEntry = Join(Array(Now, filePath, shObj.Name, safeValue, savePath, "Success", ""), ",")
        logLines.Add logEntry
    Next shObj

    srcBook.Close SaveChanges:=False
    Exit Sub

ErrHandler:
    logEntry = Join(Array(Now, filePath, "", "", "", "Failed", Err.Description), ",")
    logLines.Add logEntry
    On Error Resume Next
    If Not srcBook Is Nothing Then srcBook.Close SaveChanges:=False
End Sub

' ファイル名の重複回避
Function GenerateUniqueFileName(folder As String, baseName As String) As String
    Dim fileName As String
    Dim count As Integer
    Dim dotPos As Integer
    Dim nameOnly As String
    Dim ext As String

    fileName = folder & baseName
    If Dir(fileName) = "" Then
        GenerateUniqueFileName = fileName
        Exit Function
    End If

    dotPos = InStrRev(baseName, ".")
    If dotPos > 0 Then
        nameOnly = Left(baseName, dotPos - 1)
        ext = Mid(baseName, dotPos)
    Else
        nameOnly = baseName
        ext = ""
    End If

    count = 1
    Do
        fileName = folder & nameOnly & " (" & count & ")" & ext
        If Dir(fileName) = "" Then Exit Do
        count = count + 1
    Loop

    GenerateUniqueFileName = fileName
End Function

' ログ出力
Sub WriteLog(logLines As Collection, logPath As String)
    Dim i As Long
    Dim logFile As Integer

    logFile = FreeFile
    Open logPath For Output As #logFile
    Print #logFile, "Timestamp,SourceFile,SheetName,A1Value,OutputFile,Status,Remarks"

    For i = 1 To logLines.Count
        Print #logFile, logLines(i)
    Next i

    Close #logFile
End Sub