VBA高级筛选应用：拆分或更新子工作表

标签：VBA，高级筛选

下图1所示是一个简单的示例数据集。这里已经突出标示了Dept A（橙色），因为这是我们可能希望为这个部门创建新工作表，然而，如果已经有一个标题为“A”的工作表，那么就不会创建新工作表，只会将数据添加到现有工作表中。其中心思想是创建一个唯一的工作表，其中包含与部门相关的数据。因此，这里会为A、B和C分别创建一个工作表。如果添加了任何新的部门，则也为这些部门创建新的工作表。

图1

这将有效地使代码更长一些，因为需要对此进行测试，但它工作得很好。

下面的VBA代码有两个作用，它首先创建一个唯一列表，然后基于该唯一列表使用高级筛选。高级筛选是一个很好的工具，因为它可以在不使用复制和粘贴的情况下完成上述操作。它可以轻松地在工作表之间移动数据，而且速度非常快。

Sub AdvFilt()

Dim i As Integer

Dim sh As Worksheet

Set sh = Sheet1 '主工作表

sh.[A1:A3000].AdvancedFilter 2, sh.[M1], , 1 '唯一值

For i = 2 To sh.Range("M" & Rows.Count).End(xlUp).Row

sh.[N2] = sh.Range("M" & i)

If Not Evaluate("ISREF('" & CStr(sh.Range("M" & i)) & "'!A1)") Then

Sheets.Add(After:=Sheets(Worksheets.Count)).Name = sh.[N2]

sh.[A1].CurrentRegion.AdvancedFilter 2, sh.[N1:N2], Sheets(CStr(sh.[N2])).[A1]

End If

Sheets(CStr(sh.[N2])).[A1].CurrentRegion.ClearContents

sh.[A1].CurrentRegion.AdvancedFilter 2, sh.[N1:N2], Sheets(CStr(sh.[N2])).[A1]

Next i

sh.Range("M1:M400, N2").ClearContents

sh.Select

End Sub

这段代码首先创建唯一值列表：

sh.[A1:A3000].AdvancedFilter 2, sh.[M1], , 1

这里只是选择了前3000行，而不是创建一个动态列表。高级筛选将列出唯一值项，并将其放在M列中。

接下来，代码需要循环遍历该唯一列表，这里使用了一个简单的For循环，从第2行循环到M列中最后使用的行。

For i = 2 To sh.Range("M" & Rows.Count).End(xlUp).Row

下一步是检查工作表是否存在，这可以在不循环工作表的情况下有效地执行此操作。

If Not Evaluate("ISREF('" & CStr(sh.Range("M" & i)) & "'!A1)") Then

接下来的两个步骤是清除内容并添加数据。

Sheets(CStr(sh.[N2])).[A1].CurrentRegion.ClearContents

sh.[A1].CurrentRegion.AdvancedFilter 2, sh.[N1:N2], Sheets(CStr(sh.[N2])).[A1]

最后进行了一点整理，代码完成。

上面的代码运行得非常顺利，并在过程运行完毕后清除了一些辅助信息。注意，在单元格N1输入有部门名称，这需要保留，因为高级筛选需要标题。

注：本文学习整理自thesmallman.com，有兴趣的朋友可以到该网站下载原示例工作簿，也可以到知识星球App完美Excel社群下载中文示例工作簿。