E102影片內的語法

<aside> 💡

主要功能：

1. 建立一個以今天日期命名的資料夾，用於存儲分割後的活頁簿。
2. 從每個工作表的第一欄（A欄）中提取所有的分類。
3. 根據分類創建新的活頁簿，並將原工作表中屬於該分類的資料複製到新的活頁簿中。
4. 將分割好的活頁簿以分類命名並存檔到資料夾。 </aside>

Sub SplitWorkbookByCategory()

    Dim SourceWs As Worksheet
    Dim TargetWb As Workbook
    Dim TargetWs As Worksheet
    Dim LastRow As Long
    Dim Cell As Range
    Dim UniqueCategories As Collection
    Dim Category As Variant
    Dim FolderPath As String
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 建立今天日期的資料夾
    FolderPath = ThisWorkbook.Path & "\\" & Format(Date, "yyyy-mm-dd") & "\\"
    If Not FolderExists(FolderPath) Then MkDir FolderPath
    
    ' 取得所有的分類
    Set UniqueCategories = New Collection
    For Each SourceWs In ThisWorkbook.Worksheets
        LastRow = SourceWs.Cells(SourceWs.Rows.Count, "A").End(xlUp).Row
        For Each Cell In SourceWs.Range("A2:A" & LastRow)
            On Error Resume Next
            UniqueCategories.Add Cell.Value, CStr(Cell.Value)
            On Error GoTo 0
        Next Cell
    Next SourceWs
    
    ' 根據每個分類創建新的活頁簿
    For Each Category In UniqueCategories
        Set TargetWb = Workbooks.Add
        For Each SourceWs In ThisWorkbook.Worksheets
            SourceWs.Copy After:=TargetWb.Sheets(TargetWb.Sheets.Count)
            Set TargetWs = TargetWb.Sheets(TargetWb.Sheets.Count)
            TargetWs.Name = SourceWs.Name
            LastRow = TargetWs.Cells(TargetWs.Rows.Count, "A").End(xlUp).Row
            
            ' 從下到上刪除不吻合的分類
            For i = LastRow To 2 Step -1
                If TargetWs.Cells(i, 1).Value <> Category Then
                    TargetWs.Cells(i, 1).EntireRow.Delete
                End If
            Next i
            
        Next SourceWs
        ' 刪除默認的工作表
        Application.DisplayAlerts = False
        TargetWb.Sheets(1).Delete
        Application.DisplayAlerts = True
        
        ' 儲存並關閉活頁簿
        TargetWb.SaveAs FolderPath & Category & ".xlsx"
        TargetWb.Close SaveChanges:=False
    Next Category
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Function FolderExists(ByVal FolderPath As String) As Boolean
    On Error Resume Next
    FolderExists = (GetAttr(FolderPath) And vbDirectory) = vbDirectory
    On Error GoTo 0
End Function

依據同學需求調整版

<aside> 💡

此VBA語法的功能為根據C欄的分類項目，將Excel工作簿中的資料分割為多個檔案。每個分類會生成一個新的活頁簿，活頁簿檔名以特定文字_分類名稱命名，且工作表名稱為該分類名稱。程式會自動建立以當日日期命名的資料夾儲存這些檔案，篩選過程中保留符合分類的資料，並刪除多餘行。

</aside>

Sub SplitWorkbookByCategoryInColumnC()

    Dim SourceWs As Worksheet
    Dim TargetWb As Workbook
    Dim TargetWs As Worksheet
    Dim LastRow As Long
    Dim Cell As Range
    Dim UniqueCategories As Collection
    Dim Category As Variant
    Dim FolderPath As String
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 建立今天日期的資料夾
    FolderPath = ThisWorkbook.Path & "\\" & Format(Date, "yyyy-mm-dd") & "\\"
    If Not FolderExists(FolderPath) Then MkDir FolderPath
    
    ' 取得所有的分類 (C欄)
    Set UniqueCategories = New Collection
    For Each SourceWs In ThisWorkbook.Worksheets
        LastRow = SourceWs.Cells(SourceWs.Rows.Count, "C").End(xlUp).Row
        For Each Cell In SourceWs.Range("C2:C" & LastRow)
            On Error Resume Next
            UniqueCategories.Add Cell.Value, CStr(Cell.Value)
            On Error GoTo 0
        Next Cell
    Next SourceWs
    
    ' 根據每個分類 (C欄) 創建新的活頁簿
    For Each Category In UniqueCategories
        Set TargetWb = Workbooks.Add
        For Each SourceWs In ThisWorkbook.Worksheets
            SourceWs.Copy After:=TargetWb.Sheets(TargetWb.Sheets.Count)
            Set TargetWs = TargetWb.Sheets(TargetWb.Sheets.Count)
            
            ' 設定工作表名稱為分類名稱
            TargetWs.Name = Category
            
            LastRow = TargetWs.Cells(TargetWs.Rows.Count, "C").End(xlUp).Row
            
            ' 從下到上刪除不吻合的分類
            For i = LastRow To 2 Step -1
                If TargetWs.Cells(i, 3).Value <> Category Then
                    TargetWs.Cells(i, 3).EntireRow.Delete
                End If
            Next i
        Next SourceWs
        
        ' 刪除默認的工作表
        Application.DisplayAlerts = False
        TargetWb.Sheets(1).Delete
        Application.DisplayAlerts = True
        
        ' 儲存並關閉活頁簿 (檔名前加上 "特定文字_")
        TargetWb.SaveAs FolderPath & "特定文字_" & Category & ".xlsx"
        TargetWb.Close SaveChanges:=False
    Next Category
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Function FolderExists(ByVal FolderPath As String) As Boolean
    On Error Resume Next
    FolderExists = (GetAttr(FolderPath) And vbDirectory) = vbDirectory
    On Error GoTo 0
End Function

從第二列開始處理

Sub SplitWorkbookByCategoryInColumnC()

    Dim SourceWs As Worksheet
    Dim TargetWb As Workbook
    Dim TargetWs As Worksheet
    Dim LastRow As Long
    Dim Cell As Range
    Dim UniqueCategories As Collection
    Dim Category As Variant
    Dim FolderPath As String
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 建立今天日期的資料夾
    FolderPath = ThisWorkbook.Path & "\\" & Format(Date, "yyyy-mm-dd") & "\\"
    If Not FolderExists(FolderPath) Then MkDir FolderPath
    
    ' 取得所有的分類 (C欄)
    Set UniqueCategories = New Collection
    For Each SourceWs In ThisWorkbook.Worksheets
        LastRow = SourceWs.Cells(SourceWs.Rows.Count, "C").End(xlUp).Row
        For Each Cell In SourceWs.Range("C2:C" & LastRow)
            On Error Resume Next
            UniqueCategories.Add Cell.Value, CStr(Cell.Value)
            On Error GoTo 0
        Next Cell
    Next SourceWs
    
    ' 根據每個分類 (C欄) 創建新的活頁簿
    For Each Category In UniqueCategories
        Set TargetWb = Workbooks.Add
        Set TargetWs = TargetWb.Sheets(1)
        
        ' 初始化目標工作表，複製第一列和第二列
        For Each SourceWs In ThisWorkbook.Worksheets
            SourceWs.Rows(1).Copy TargetWs.Rows(1) ' 複製第一列
            SourceWs.Rows(2).Copy TargetWs.Rows(2) ' 複製第二列
        Next SourceWs
        
        ' 追加分類相關資料從第三列開始
        Dim TargetRow As Long
        TargetRow = 3
        
        For Each SourceWs In ThisWorkbook.Worksheets
            LastRow = SourceWs.Cells(SourceWs.Rows.Count, "C").End(xlUp).Row
            
            For i = 2 To LastRow ' 從第二列開始處理
                If SourceWs.Cells(i, 3).Value = Category Then
                    SourceWs.Rows(i).Copy TargetWs.Rows(TargetRow)
                    TargetRow = TargetRow + 1
                End If
            Next i
        Next SourceWs
        
        ' 儲存並關閉活頁簿 (檔名前加上 "特定文字_")
        TargetWb.SaveAs FolderPath & "特定文字_" & Category & ".xlsx"
        TargetWb.Close SaveChanges:=False
    Next Category
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Function FolderExists(ByVal FolderPath As String) As Boolean
    On Error Resume Next
    FolderExists = (GetAttr(FolderPath) And vbDirectory) = vbDirectory
    On Error GoTo 0
End Function