根据两个条件/列每个条件在一列中将一张工作表拆分为不同的工作表

问题描述

我有一个文件，其中 A 列具有不同的名称，B 列具有不同的部门（A 中的那个人所属）。 C-E 列是每个人的相关数据。我在网上搜索，发现有一些 VBA 代码可以根据一列将一张工作表拆分为多张工作表。我想知道是否有一种方法可以拆分同时考虑两列的工作表？ Ps：拆分的工作表将以A列和B列的内容命名。
这是我用来基于一列拆分的代码。欢迎任何建议。非常感谢。

Sub parse_data()
    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

    'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
    'An InputBox asks you which columns you'd like to filter by,and it just creates these worksheets.

    Application.ScreenUpdating = False
    vcol = Application.InputBox(prompt:="Which column would you like to filter by?",title:="Filter column",Default:="3",Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count,vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1,icol) = "Unique"
    For i = 2 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
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.copy Sheets(myarr(i) & "").Range("A1")
        'Sheets(myarr(i) & "").Columns.AutoFit
    Next

    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True
End Sub

解决方法

Dictionaries 可用于创建唯一值列表。

Option Explicit

Sub CreateDeptPerson()

    Const RNG_HEADER = "A1:E1"
    Const START_ROW = 2 ' row 1 header

    Dim wb As Workbook,ws As Worksheet,arHeader As Variant
    Dim iRow As Long,iLastRow As Long,i As Long,n As Integer

    Dim dict As Object,key As String
    Set dict = CreateObject("Scripting.Dictionary")

    ' add existing sheets to dictionary
    Set wb = ThisWorkbook
    For Each ws In wb.Sheets
        iRow = ws.UsedRange.Rows.Count + ws.UsedRange.Row ' last row +1
        dict.Add ws.Name,iRow
    Next

    ' extent of  data
    Set ws = wb.Sheets("Sheet1") ' change to name of data sheet
    iLastRow = ws.Cells(Rows.Count,"A").End(xlUp).Row
    arHeader = ws.Range(RNG_HEADER).Value2
    
    ' scan down column A
    For iRow = START_ROW To iLastRow
        'sheet name as "dept name"
        key = Trim(ws.Cells(iRow,"B")) & " " & Trim(ws.Cells(iRow,"A"))

        ' add a sheet if not in dictionary
        If Not dict.exists(key) Then
           With wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
               .Name = key
               .Range(RNG_HEADER) = arHeader
           End With
           ' add name to dictionary
           dict.Add key,2
           n = n + 1
        End If

        ' copy row to the sheet named key
        i = dict(key)
        ws.Cells(iRow,1).EntireRow.Copy wb.Sheets(key).Cells(i,1)
        dict(key) = i + 1 'move down for next record
    Next
    MsgBox n & " Sheets Created"

End Sub