MsgBox后类型不匹配错误

Question

我的数据如下。

更新问题

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 

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

Answer 1

当你添加了一些收集的关键需求是一个字符串，因此使用：

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

代替：

coll.Add r.Value, r.Value 

你还在分配coll(j)到Variant这不是一个阵列。 您需要：

ReDim myArr(1 to coll.Count) 

您的循环之前，然后在循环：

myArr(j) = coll(j) 

Answer 2

之前试图对这一问题作出回应，我想什么写什么，我相信你正在试图完成;当你确认这是你正在做的事情时，我会尽力帮你获得工作代码来实现它。这通常被用做评论，但评论的主题至今都有点脱节，并且代码相当复杂...

1. 你在一个表（称为“工作表Sheet1”有数据 - 这可能是虽然其他人）的东西
2. 第一列包含可能被重复
3. 你不知道有多少列可能有一定的价值......你想知道的是，虽然
4. 你试图找到每一个独特的A列中的值（称为“键值”），并将其显示在消息框中（一次一个）。这看起来更像是一个调试步骤，而不是最终程序的实际功能。
5. 然后打开A列上的自动过滤器;只选择与某个值匹配的行
6. 使用与工作表名称相同的值，可以看到这样的工作表是否存在：如果存在，则清除其内容;如果没有，则在工作簿末尾创建它（并将其命名为键）
7. 您选择sheet1上列A中具有相同（键）值的所有行，并将它们复制到其名称等于您过滤的列A中的值
8. 您想对列A中的每个唯一（键）值重复步骤5-8当完成所有操作后，我相信您已经完成（至少）多于一列的表格，而不是A列中的关键值（您还有初始数据表）;但是，您不会删除任何“多余”表（使用其他名称）。每张纸将只有对应于工作表1当前内容的数据行（任何较早的数据被删除）。
9. 在操作过程中，您可以打开或关闭自动过滤功能;你想结束自动过滤器禁用。

请确认这是你在试图做的确是。如果您能够了解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