Filter data and then copy and paste the distinct values

Question

I have some experience in VBA but I am not an expert and need some advice on how to solve my problem. I have a database that I need to apply 2 filters on. I have the following code for the two filters:

Sub Filtering()
    'Filter Plant
    If IsEmpty(Worksheets("Material Planning").Range("D1")) = False Then
     If Worksheets("Material Planning").Range("D1") = "All" Then
      Worksheets("Inventory").Range("A:X").AutoFilter 'removes any filters
     Else
      Worksheets("Inventory").Range("A:X").AutoFilter Field:=1, Criteria1:=Worksheets("Material Planning").Range("D1")
     End If
    End If
    
    'Filter SLoc
    If IsEmpty(Worksheets("Material Planning").Range("D2")) = False Then
     If Worksheets("Material Planning").Range("D2") = "All" Then
      Worksheets("Inventory").Range("A:X").AutoFilter 'removes any filters
     Else
      Worksheets("Inventory").Range("A:X").AutoFilter Field:=2, Criteria1:=Worksheets("Material Planning").Range("D2")
     End If
    End If
End Sub

Once that is completed, I need to extract the Distinct Values and paste then into a different sheet. I know that the second half can be achieved by manipulating the following code:

Sub ExtractDistinct()
Dim lastrow As Long

lastrow = Worksheets("Inventory").Cells(Rows.Count, "H").End(xlUp).Row

    Worksheets("Inventory").Range("H2:H" & lastrow).AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=Worksheets("Dictionary").Range("D4"), _
    Unique:=True

End Sub

Using the code above gives me the distinct value that I am looking for, but it does not do it to the filtered range that I had from the ".AutoFilter" code from before. It gives me the distinct values from the data unfiltered, and removes any filters that I had on the data.

I was able to get the ".autofilter" to filter the raw data in the worksheet I was using but having the data physically filtered in excel is not what I am looking for (Also seems to be taxing on the processing). I want to be able to filter the data from column A and B, then extract all of the distinct values from the Filtered Data From Column C and copy that to a separate sheet(not a new sheet).

Thank you for your help!

VBasic2008 · Accepted Answer

Unique Values from Filtered Range

Option Explicit

Sub filterUnique()
    
    ' Declare a boolean which will indicate if successful.
    Dim dataCopied As Boolean
    
    ' Define workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Define Criteria Values.
    Dim Crit1 As Variant
    Crit1 = wb.Worksheets("Material Planning").Range("D1").Value
    Dim Crit2 As Variant
    Crit2 = wb.Worksheets("Material Planning").Range("D2").Value
    
    Application.ScreenUpdating = False
    
    ' Define Source Worksheet
    Dim ws As Worksheet: Set ws = wb.Worksheets("Inventory")
    ' Remove AutoFilter.
    ws.AutoFilterMode = False
    ' Define Souce Range (you may need to do it another way).
    Dim srg As Range: Set srg = ws.Range("A1").CurrentRegion
    
    ' Apply filters to Source Range.
    If Not IsEmpty(Crit1) Then
        If Crit1 = "All" Then
            srg.AutoFilter
        Else
            srg.AutoFilter Field:=1, Criteria1:=Crit1
        End If
    End If
    If Not IsEmpty(Crit2) Then
        If Crit2 = "All" Then
            srg.AutoFilter
        Else
            srg.AutoFilter Field:=2, Criteria1:=Crit2
        End If
    End If
 
    ' Attempt to define Copy Range.
    On Error Resume Next
    Dim crg As Range
    Set crg = srg.Columns(3).Resize(srg.Rows.Count - 1).Offset(1) _
        .SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' If Copy Range was defined (i.e. a reference to it was created)...
    If Not crg Is Nothing Then
        ' Write unique (distinct) values to Unique Dictionary.
        Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
        dict.CompareMode = vbTextCompare
        Dim arg As Range
        Dim cel As Range
        Dim Key As Variant
        For Each arg In crg.Areas
            For Each cel In arg.Cells
                Key = cel.Value
                If Not IsError(Key) Then
                    If Len(Key) > 0 Then
                        dict(Key) = Empty
                    End If
                End If
            Next cel
        Next arg
        Dim rCount As Long: rCount = dict.Count
        If rCount > 0 Then
            ' Write unique values from Unique Dictionary to Data Array.
            Dim Data As Variant
            Dim i As Long
            ReDim Data(1 To rCount, 1 To 1)
            For Each Key In dict.Keys
                i = i + 1
                Data(i, 1) = Key
            Next Key
            ' Write values from Data Array to Dictionary Worksheet.
            With wb.Worksheets("Dictionary").Range("D4")
                .Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
                .Resize(i).Value = Data
                dataCopied = True
            End With
        End If
    End If

    Application.ScreenUpdating = True
    
    If dataCopied Then
        MsgBox "Unique values transferred.", vbInformation, "Success"
    Else
        MsgBox "Nothing transferred.", vbExclamation, "Fail?"
    End If
    
End Sub

Filter data and then copy and paste the distinct values

Answers (2)

Unique Values from Filtered Range

Related Questions