在尝试回答这个问题之前，我想写下我认为您正在努力完成的事情；当您确认这是您正在尝试做的事情时，我会尽力帮助您获得工作代码来实现它。这通常是通过注释来完成的，但到目前为止，注释的线程有点脱节，而且代码相当复杂......
- 您在工作表中有数据（称为“sheet1” - 虽然它可能是别的东西）
- 第一列包含某些可能重复的值
- 您不知道可能有多少列......但您想知道
- 您尝试在 A 列中查找每个唯一值（将其称为“键值”），并将其（一次一个）显示在消息框中。这看起来更像是一个调试步骤，而不是最终程序的实际功能。
- 然后打开 A 列的自动过滤器；仅选择与某个值匹配的行
- 使用与工作表名称相同的值，您可以查看这样的工作表是否存在：如果存在，则清除其内容；如果没有，那么您在工作簿的末尾创建它（并给它键的名称）
- 您在 sheet1 的 A 列中选择具有相同（键）值的所有行，并将它们复制到名称等于您过滤的 A 列中的值的工作表
- 您想为 A 列中的每个唯一（键）值重复步骤 5-8
- 完成所有操作后，我相信您（至少）比 A 列中的键值多一张（您还拥有初始数据表）；但是，您不会删除任何“多余的”工作表（使用其他名称）。每个工作表将只有与 sheet1 的当前内容相对应的数据行（任何早期数据都已删除）。
- 在操作过程中，您可以打开和关闭自动过滤；您希望最终禁用自动过滤器。
请确认这确实是您正在尝试做的事情。如果您可以了解 A 列中值的格式，那将很有帮助。我怀疑有些事情可以比你现在做的更有效率。最后，我确实想知道以这种方式组织数据的全部目的是否可能是以特定方式组织数据，并可能进行进一步的计算/图表等。Excel（VBA）内置了各种功能数据提取的工作更容易 - 这种数据重新排列对于完成特定工作是必要的，这种情况很少见。如果您愿意对此发表评论...
以下代码完成上述所有操作。请注意使用 forFor Each和函数/子例程来处理某些任务（unique、createOrClear和worksheetExists）。这使得顶层代码更容易阅读和理解。另请注意，错误捕获仅限于我们检查工作表是否存在的一小部分 - 对我来说它运行没有问题；如果发生任何错误，请告诉我工作表中的内容，因为这可能会影响发生的情况（例如，如果列中的单元格A包含工作表名称中不允许的字符等/\!。另请注意，您的代码正在删除“ CurrentRegion”。根据您要实现的目标，“UsedRange”可能会更好......
Option Explicit
Sub Solution()
Dim shData As Worksheet
Dim nameRange As Range
Dim r As Range, c As Range, A1c As Range, s As String
Dim uniqueNames As Variant, v As Variant
Set shData = Sheets("Sheet1") ' sheet with source data
Set A1c = shData.[A1] ' first cell of data range - referred to a lot...
Set nameRange = Range(A1c, A1c.End(xlDown)) ' find all the contiguous cells in the range
' find the unique values: using custom function
' omit second parameter to suppress dialog
uniqueNames = unique(nameRange, True)
Application.ScreenUpdating = False ' no need for flashing screen...
' check if sheet with each name exists, or create it:
createOrClear uniqueNames
' filter on each value in turn, and copy to corresponding sheet:
For Each v In uniqueNames
A1c.AutoFilter Field:=1, Criteria1:=v, _
Operator:=xlAnd
A1c.CurrentRegion.Copy Sheets(v).[A1]
Next v
' turn auto filter off
A1c.AutoFilter
' and screen updating on
Application.ScreenUpdating = True
End Sub
Function unique(r As Range, Optional show)
' return a variant array containing unique values in range
' optionally present dialog with values found
' inspired by http://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array
Dim d As Object
Dim c As Range
Dim s As String
Dim v As Variant
If IsMissing(show) Then show = False
Set d = CreateObject("Scripting.Dictionary")
' dictionary object will create unique keys
' have to make it case-insensitive
' as sheet names and autofilter are case insensitive
For Each c In r
d(LCase("" & c.Value)) = c.Value
Next c
' the Keys() contain unique values:
unique = d.Keys()
' optionally, show results:
If show Then
' for debug, show the list of unique elements:
s = ""
For Each v In d.Keys
s = s & vbNewLine & v
Next v
MsgBox "unique elements: " & s
End If
End Function
Sub createOrClear(names)
Dim n As Variant
Dim s As String
Dim NewSheet As Worksheet
' loop through list: add new sheets, or delete content
For Each n In names
s = "" & n ' convert to string
If worksheetExists(s) Then
Sheets(s).[A1].CurrentRegion.Clear ' UsedRange might be better...?
Else
With ActiveWorkbook.Sheets
Set NewSheet = .Add(after:=Sheets(.Count))
NewSheet.Name = s
End With
End If
Next n
End Sub
Function worksheetExists(wsName)
' adapted from http://www.mrexcel.com/forum/excel-questions/3228-visual-basic-applications-check-if-worksheet-exists.html
worksheetExists = False
On Error Resume Next
worksheetExists = (Sheets(wsName).Name <> "")
On Error GoTo 0
End Function