根据列值将启用宏的文件拆分为单独的文件

Question

假设我有一个文件，其中已经包含应用于数据的宏。我想根据区域列将该文件拆分为多个文件，这样我必须将拆分文件中的所有宏函数也保留在原始文件中。请告诉我如何在 VBA 中做到这一点。

Sub SplitEachWorksheet()
    Dim FPath As String
    FPath = Application.ActiveWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each ws In ThisWorkbook.Sheets
        ws.Copy
        Application.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, 
    Filename:=FPath & "\" & ws.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
    Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub

但我不知道如何通过保留原始文件中的宏功能来进行拆分。请告诉我该怎么做。

Answer 1

如果你想在 VBA 中这样做，我建议你编写代码：

• 从 Region 列中查找所有值
• 对于每个区域：
  • 制作原始文件的完整副本（包括宏的）
  • 删除所有不属于该区域的行

---

您必须将执行拆分和复制的宏放在单独的工作簿中。 我将假设该区域位于第一张工作表的第一列，并且所有相关数据都在第一张工作表上。您必须在代码中更改它以匹配工作簿中的位置 我假设原始工作簿没有打开。你可能想在你的代码中关闭它。

Sub kopieer()
    Dim macro_wb As Workbook
    Dim macro_ws As Worksheet

    Dim orig_wb As Workbook
    Dim orig_ws As Worksheet
    Dim orig_range As Range
    Dim origpath As String
    Dim origname As String

    Dim region_wb As Workbook
    Dim region_ws As Worksheet
    Dim region As String
    Dim region_wb_name As String
    Dim region_row As Integer

    Application.ScreenUpdating = False

    origname = "D:\Oefen\test\Test_0.xlsm"

    ' Use this workbook to  find the regions
    Set macro_wb = ThisWorkbook
    Set macro_sheet = Sheet1
    macro_sheet.Cells.Clear

    Set orig_wb = Application.Workbooks.Open(Filename:=origname)
    origpath = orig_wb.Path
    ' Assuming the region is in first column of first Sheet
    Set orig_ws = orig_wb.Sheets(1)
    Set orig_range = orig_ws.Range([A2], [A2].End(xlDown))
    orig_range.Copy (Sheet1.[A1])
    orig_wb.Close

    ' Now we have all regions in column 1 of first sheet
    Sheet1.Range([A1], [A1].End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo

    ' loop throught the regions
    For row = 1 To Sheet1.[A1].End(xlDown).row
        region = Sheet1.Cells(row, 1)
        ' Make a full copy of the original file (including the macro's)
        region_wb_name = origpath + "\" + region + ".xlsm"
        FileCopy origname, region_wb_name
        ' Delete all rows which don't belong to that region
        Set region_wb = Application.Workbooks.Open(region_wb_name)
        Set region_ws = region_wb.Sheets(1)
        ' We are deleting rows, so we should start at the bottom
        For region_row = region_ws.[A2].End(xlDown).row To 2 Step -1
            If region_ws.Cells(region_row, 1).Value <> region Then
                region_ws.Rows(region_row).Delete
            End If
        Next region_row
        region_wb.Save
        region_wb.Close
    Next row

    Application.ScreenUpdating = True
End Sub