Filter a dynamic range with multiple criteria and save each filtered result in predefined sheet using VBA,VBA Teacher Sourav,Kolkata 08910141720

Function RemoveDupesColl(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from your array using the collection method.
'NOTES: (1) This function returns unique elements in your array, but
' it converts your array elements to strings.

'-----------------------------------------------------------------------
    Dim i As Long
    Dim arrColl As New Collection
    Dim arrDummy() As Variant
    Dim arrDummy1() As Variant
    Dim item As Variant
    ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

    For i = LBound(MyArray) To UBound(MyArray) 'convert to string
        arrDummy1(i) = CStr(MyArray(i))
    Next i
    On Error Resume Next
    For Each item In arrDummy1
       arrColl.Add item, item
    Next item
    Err.Clear
    ReDim arrDummy(LBound(MyArray) To arrColl.Count + LBound(MyArray) - 1)
    i = LBound(MyArray)
    For Each item In arrColl
       arrDummy(i) = item
       i = i + 1
    Next item
    RemoveDupesColl = arrDummy
End Function


Sub filterandpastedata()


Sheets("Sheet2").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If


Dim uniquedata()
Dim samplerange As Range

 Set samplerange = ActiveSheet.Range("E2", ActiveSheet.Range("E2").End(xlDown))
'MsgBox (samplerange.Rows.Count)
ReDim Preserve uniquedata(samplerange.Rows.Count)
Dim dict As Object
Dim length As Long
length = 0
Range("E2").Select
While ActiveCell.Value <> ""

uniquedata(length) = ActiveCell.Value
length = length + 1
ActiveCell.Offset(1, 0).Select
Wend

'For length = LBound(uniquedata) To UBound(uniquedata) - 1
'MsgBox (uniquedata(length))
'Next length
Dim uniquedatafinal()
uniquedatafinal = RemoveDupesColl(uniquedata)
'For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
'MsgBox (uniquedatafinal(length))
'Next length


'now we found the unique names ,let us first delete anysheet containing such unique names and create sheets containing those names
Dim tempsheetname As String
 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
   
  For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
tempsheetname = (uniquedatafinal(length))

For Each wks In Application.Worksheets
        If wks.Name = tempsheetname Then wks.Delete
    Next

Next length

 For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
     cntsheets = Application.Sheets.Count
    Set NewSheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    NewSheet.Name = uniquedatafinal(length)
    Next length
   
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

'Now creating sheets is done ,let us go back the data sheet and remove any filter from the sheet

Sheets("Sheet2").Select



Dim dataforfilter As String


For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
dataforfilter = Replace(ActiveSheet.Range("E1").CurrentRegion.Address, "$", "")
ActiveSheet.Range(dataforfilter).AutoFilter Field:=1, Criteria1:=uniquedatafinal(length), Operator:=xlFilterValues
ActiveSheet.Range(dataforfilter).AutoFilter Field:=4, Criteria1:="=Yes", Operator:=xlFilterValues

ActiveSheet.Range("E1").CurrentRegion.Select
Selection.Copy

Sheets(uniquedatafinal(length)).Select
Range("A1").PasteSpecial xlPasteValues

Sheets("Sheet2").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If

Next length

If ActiveSheet.AutoFilterMode Then

     ActiveSheet.AutoFilterMode = False

End If

End Sub