Type Mismatch Error after MsgBox

Question

my data is as below .

Updated 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

When I run above macro I don't know why it is giving Type Mismatch Error after MsgBox coll(j) , simply I want to store data in Array and I'm passing that data , Here I am using For Each r In Range("A1:A10") Where A10 length is static how can I find last written column?

Answer 1

Before attempting to respond to this question, I would like to write what I believe you are trying to accomplish; when you confirm this is what you are trying to do, I will try to help you get working code to achieve it. This would normally be done with comments, but the threads of comments so far are a bit disjointed, and the code is quite complex...

1. You have data in a sheet (called "sheet1" - it might be something else though)
2. The first column contains certain values that might be repeated
3. You don't know how many columns there might be... you would like to know that though
4. You attempt to find each unique value in column A (call it the "key value"), and display it (one at a time) in a message box. This looks more like a debug step than actual functionality for the final program.
5. You then turn on the autofilter on column A; selecting only rows that match a certain value
6. Using that same value as the name of a sheet, you see if such a sheet exists: if it does, you clear its contents; if it does not, then you create it at the end of the workbook (and give it the name of the key)
7. You select all rows with the same (key) value in column A on sheet1, and copy them to the sheet whose name is equal to the value in column A that you filtered on
8. You want to repeat step 5-8 for each of the unique (key) values in column A
9. When all is done, I believe you have (at least) one more sheet than you had key values in column A (you also have the initial data sheet); however you do not delete any "superfluous" sheets (with other names). Each sheet will have only rows of data corresponding to the current contents of sheet1 (any earlier data was deleted).
10. During the operation you turn autofiltering on and off; you want to end up with auto filter disabled.

Please confirm that this is indeed what you are attempting to do. If you could give an idea of the format of the values in column A, that would be helpful. I suspect that some things could be done rather more efficiently than you are currently doing them. Finally I do wonder whether the whole purpose of organizing your data in this way might be to organize the data in a specific way, and maybe do further calculations / graphs etc. There are all kinds of functions built in to excel (VBA) to make the job of data extraction easier - it's rare that this kind of data rearranging is necessary to get a particular job done. If you would care to comment on that...

The following code does all the above. Note the use for For Each, and functions / subroutines to take care of certain tasks (unique, createOrClear, and worksheetExists). This makes the top level code much easier to read and understand. Also note that the error trapping is confined to just a small section where we check if a worksheet exists - for me it ran without problems; if any errors occur, just let me know what was in the worksheet since that might affect what happens (for example, if a cell in column A contains a character not allowed in a sheet name, like /\! etc. Also note that your code was deleting "CurrentRegion". Depending on what you are trying to achieve, "UsedRange" might be better...

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

Answer 2

When you add something to collection the key needs to be a string so use:

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

instead of:

coll.Add r.Value, r.Value

You are still assigning coll(j) to a Variant which is not an array. You need to:

ReDim myArr(1 to coll.Count)

Before your for loop and then in the loop:

myArr(j) = coll(j)