MsgBox后types不匹配错误

我的数据如下。

更新了问题

Sub Solution() Dim shData As Worksheet Set shData = Sheets("Sheet1") 'or other reference to data sheet Dim coll As Collection, r As Range, j As Long Dim myArr As Variant Dim shNew As Worksheet shData.Activate 'get unique values based on Excel features Range("a1").AutoFilter Set coll = New Collection On Error Resume Next For Each r In Range("A1:A10") coll.Add r.Value, r.Value Next r On Error GoTo 0 'Debug.Print coll.Count For j = 1 To coll.Count MsgBox coll(j) myArr = coll(j) Next j Range("a1").AutoFilter Dim i As Long For i = 0 To UBound(myArr) shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _ Operator:=xlAnd On Error Resume Next Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents If Err.Number = 0 Then Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1") Else Set shNew = Sheets.Add(After:=Sheets(Sheets.Count)) shData.Range("A1").CurrentRegion.Copy shNew.Range("A1") shNew.Name = myArr(i) Err.Clear End If Next i 'removing filter in master sheet shData.Range("a1").AutoFilter End Sub 

当我运行上面的macros，我不知道为什么它是在MsgBox coll(j)后给出Type Mismatch Error ，只是我想存储数据在数组中，我传递的数据，在这里我使用For Each r In Range("A1:A10")如果A10长度是静态的，我怎样才能find上一个写入的列？

Answer 1

当你添加的东西收集的关键需要是一个string，所以使用：

 coll.Add r.Value, CStr(r.Value) 

代替：

 coll.Add r.Value, r.Value 

您仍然将coll(j)分配给不是数组的Variant 。 你需要：

 ReDim myArr(1 to coll.Count) 

在for循环之前，然后在循环中：

 myArr(j) = coll(j) 

Answer 2

在试图回答这个问题之前，我想写下我相信你正在努力完成的事情。 当你确认这是你正在做的事情时，我会尽力帮你获得工作代码来实现它。 这通常是通过评论来完成的，但是到目前为止，评论的主题是有点脱节，代码是相当复杂的。

1. 你有一张表格中的数据（称为“sheet1” – 可能是别的东西）
2. 第一列包含可能会重复的某些值
3. 你不知道有多less列可能…你想知道，但是
4. 您试图find列A中的每个唯一值（称为“键值”），并将其显示在消息框中（一次一个）。 这看起来更像是一个debugging步骤，而不是最终程序的实际function。
5. 然后打开A列上的自动filter; 只select匹配某个值的行
6. 使用与表单名称相同的值，可以看到这样的表单是否存在：如果存在，则清除其内容; 如果没有，那么你在工作簿的末尾创build它（并给出它的名称）
7. 您在工作表1的列A中select具有相同（键）值的所有行，并将其复制到名称等于您筛选的列A中的值的工作表
8. 您希望为列A中的每个唯一（键）值重复步骤5-8
9. 完成所有工作后，我相信你至less还有一个工作表，而不是你在A栏中的关键值（你也有最初的数据表）。 但是，您不要删除任何“多余的”工作表（使用其他名称）。 每张纸将只有对应于工作表1的当前内容的数据行（任何较早的数据被删除）。
10. 在操作过程中，您可以打开或closures自动过滤function。 你想结束自动filter禁用。

请确认这确实是你正在尝试做的。 如果你能想出列A中的值的格式，这将是有帮助的。 我怀疑有些事情可能比你现在做的更有效率。 最后我想知道以这种方式组织数据的整个目的是为了以特定的方式组织数据，或者进一步计算/绘制图表等。有许多内置于Excel的函数（VBA）数据提取的工作更容易 – 这种数据重新排列是完成特定工作所必需的。 如果你愿意评论这个…

以下代码完成以上所有操作。 注意For 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