Autofilter and Copy Result to New Sheet, But Excel Prompted Error 1004

[epoiezam]

Hi Guys:

Got this one code, to Autofilter multiple values in a master sheets and copy each met criteria's to new sheet and named.
The code run nicely until it reaches the tenth sheet and system starts to prompted the error below.
Well I can't blame the system, since the list in the master sheet is huge.

Run Time error 1004. Application defined or object defined error.

'Start Here

    Dim x       As Long
    Dim y       As Long
  
    Dim dic     As Object
    Dim arr()   As Variant
    Dim var     As Variant
    Dim rng     As Range
  
    Set dic = CreateObject("Scripting.Dictionary")
    y = Range("AT1").Column

    Application.ScreenUpdating = False

    With Sheets("Export Worksheet")
        arr = .Cells(6, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 5, y).Value
  
        For x = LBound(arr, 1) To UBound(arr, 1)
            Set rng = .Cells(x + 5, 1).Resize(, y)
            If dic.exists(arr(x, 1)) Then Set rng = Union(dic(arr(x, 1)), rng)
            Set dic(arr(x, 1)) = rng
        Next x
    End With
  
    Erase arr
    Set rng = Nothing
  
    For Each var In dic
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = CStr(var)
        With Sheets(CStr(var))
            dic(var).Copy
            .Cells(1, 1).PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End With
    Next var
  
    Application.ScreenUpdating = True
  
    Set dic = Nothing

'End Here

 

[Peter_SSs]

When posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug. My signature block below has more details. I have added the tags for you this time.

Also, when you get a vba error it would help if you identified which line of the code caused the error.

I also suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[epoiezam]

When posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug. My signature block below has more details. I have added the tags for you this time.

Also, when you get a vba error it would help if you identified which line of the code caused the error.

I also suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

Hi Peter,
Thank you for the assistance. I've update the necessary info.

 

[Peter_SSs]

Thanks for updating your version details.

.. but you didn't update us on what line in the code triggered the error.

One further point of clarification too ..

Got this one code, to Autofilter multiple values ..

.. but the code does not AutoFilter anything and we are unsure of just what your data is like.

 

[epoiezam]

Managed to find the solution. It's perfect..

Sharing it with future readers.

Dim lr As Long
Dim ws As Worksheet
Dim vcol As Integer
Dim i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' *** Adjust the next three instructions to your situation: '
' ws should show the name of your Data Worksheet '
' title should show the columns from your Data worksheet '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'''''''''''''''''''''''''
vcol = 3               ' Column C
Set ws = Sheets("Main Data") ' Define the Source Worksheet
title = "A1:F1"        ' Define the Headers Range
'''''''''''''''''''''''''


Application.ScreenUpdating = False
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Cells(1, Application.Columns.Count).End(xlToLeft).Column + 1
ws.Cells(1, icol) = "Unique"


 For i = 2 To lr
 On Error Resume Next
 If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
 ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
 End If
 Next i
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
 For i = 2 To UBound(myarr)
 ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
 If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
 Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
 Else
 Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
 End If
 ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
 Sheets(myarr(i) & "").Columns.AutoFit
 Next i
ws.AutoFilterMode = False
ws.Activate
MsgBox " DONE ... !!! "