根据 VBA 的列将 Excel 工作表拆分为多个工作表

Question

我有以下数据：

Data in sheet 1 :

Name    Fund Source Remark  Approved (Y/N)
Alice   C&C Ok  Y
John    C&C Ok  N

Data in sheet 2 :

 Sr No   Name   Category     Requirement - A     Requirement - B     Requirement - C     Requirement - D    Eligibility Remarks
1   Alice   A+  3   2   0   0   Ok  

Data in sheet 3 :

 Month  Delivery     Support Pay    Client Name  Remark     Mfg Year    Model Year  Remarks
Jan Cash     269    Alice       2022    2022    

问题很简单，可能会重复。

1. 我有一个 Excel 工作簿，其中包含 3 张

2. 我有一个标准列，应该应用于所有 3 张工作表，以将此工作簿拆分为多个工作簿

我正在寻找一个宏，它使我能够基于Name列创建多个 Excel 工作簿，例如：

• 所有姓名的 Excel/CSV，如爱丽丝、约翰

我在这里面临的唯一挑战是

1. header 应该应用过滤条件在工作表 3 中是不同的（在工作表 1 和 2 中 header 是客户，但在工作表 3 中它被命名为客户名称）

最终的工作簿应该包含 3 张，但应该只显示一个人的名字（例如，这里将创建 2 个不同的工作簿，一个给 Alice，另一个给 John）

我曾尝试在 VBA 中编码，但只能过滤一张纸。 有人可以帮我用一个宏来帮助我根据上述细节生成多个工作簿吗？

这是代码：

Sub Splitdatabycol()
    
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim xTRg As Range
    Dim xVRg As Range
    Dim xWSTRg As Worksheet
    Dim xWS As Worksheet
    
    On Error Resume Next
    
    Set xTRg = Application.InputBox("Please select the header rows:", "Prompt", "", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Prompt", "", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    
    vcol = xVRg.Column
    Set ws = xTRg.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = xTRg.AddressLocal
    titlerow = xTRg.Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    
    Application.DisplayAlerts = False
    
    If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
    Else
        Sheets("xTRgWs_Sheet").Delete
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
    End If
    
    Set xWSTRg = Sheets("xTRgWs_Sheet")
    xTRg.Copy
    xWSTRg.Paste Destination:=xWSTRg.Range("A1")
    ws.Activate
    
    For i = (titlerow + xTRg.Rows.Count) To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next
    
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
            xWS.Name = myarr(i) & ""
        Else
            xWS.Move after:=Worksheets(Worksheets.Count)
        End If
        xWSTRg.Range(title).Copy
        xWS.Paste Destination:=xWS.Range("A1")
        ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
        Sheets(myarr(i) & "").Columns.AutoFit
    Next
    
    xWSTRg.Delete
    ws.AutoFilterMode = False
    ws.Activate
    Application.DisplayAlerts = True

End Sub

Answer 1

我认为高级过滤器可能适用于这种情况：

Sub newWorkbookPerName()
      
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, splitWb As Workbook
    Dim ws1EndColumn As Long, ws2EndColumn As Long, ws3EndColumn As Long
    Dim ws1Name As Long, ws2Name As Long, ws3Name As Long
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")
    
    If ws1.Range("A2").Value2 <> "" Then
        ws1EndColumn = ws1.Range("A1").End(xlToRight).Column
        ws2EndColumn = ws2.Range("A1").End(xlToRight).Column
        ws3EndColumn = ws3.Range("A1").End(xlToRight).Column
    
        'Use AdvancedFilter to filter and copy data - https://excelmacromastery.com/vba-advanced-filter/
        'use match to find Name column
        ws1Name = Application.WorksheetFunction.Match("Name", ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, ws1EndColumn)), 0)
        ws2Name = Application.WorksheetFunction.Match("Name", ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, ws1EndColumn)), 0)
        ws3Name = Application.WorksheetFunction.Match("*Name", ws3.Range(ws3.Cells(1, 1), ws3.Cells(1, ws1EndColumn)), 0)
        'Put together criteria range for AdvanceFilter
        ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, ws1EndColumn)).Offset(0, ws1EndColumn + 5).Value2 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, ws1EndColumn)).Value2
        ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, ws2EndColumn)).Offset(0, ws2EndColumn + 5).Value2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, ws2EndColumn)).Value2
        ws3.Range(ws3.Cells(1, 1), ws3.Cells(1, ws3EndColumn)).Offset(0, ws3EndColumn + 5).Value2 = ws3.Range(ws3.Cells(1, 1), ws3.Cells(1, ws3EndColumn)).Value2
        For Each Name In ws1.Range("A2", ws1.Range("A1").End(xlDown))
            Workbooks.Add
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Name & ".xlsx"
            Set splitWb = ActiveWorkbook
            'Sheet1
            ws1.Cells(2, ws1Name).Offset(0, ws1EndColumn + 5).Value2 = Name
            ws1.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, ws1.Cells(1, ws1EndColumn + 6).CurrentRegion, splitWb.Worksheets("Sheet1").Range("A1")
            'Sheet2
            splitWb.Sheets.Add after:=splitWb.Worksheets(splitWb.Worksheets.Count)
            ws2.Cells(2, ws2Name).Offset(0, ws2EndColumn + 5).Value2 = Name
            ws2.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, ws2.Cells(1, ws2EndColumn + 6).CurrentRegion, splitWb.Worksheets("Sheet2").Range("A1")
            'Sheet3
            splitWb.Sheets.Add after:=splitWb.Worksheets(splitWb.Worksheets.Count)
            ws3.Cells(2, ws3Name).Offset(0, ws3EndColumn + 5).Value2 = Name
            ws3.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, ws3.Cells(1, ws3EndColumn + 6).CurrentRegion, splitWb.Worksheets("Sheet3").Range("A1")
            splitWb.Close SaveChanges:=True
        Next
    End If

End Sub