I am trying to copy, filter the values of column D = India and France and Column C > 1/06/2020 and paste those unique filtered values in the another worksheet, Could you please help me?

I tried to do it but i couldn't manage to create multiple filters and copy only the unique values

Public Sub ConditionalRowCopy()

    ' Declare object variables
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim cell As Range

    ' Declare other variables
    Dim sourceLastRow As Long
    Dim targetLastRow As Long

    ' Set a reference to the sheets so you can access them later
    Set sourceSheet = Workbooks("Bookcopy.xlsm").Worksheets("copy")
    Set targetSheet = Workbooks("Bookpaste.xlsm").Worksheets("paste")

    ' Find last row in source sheet based on column "R"
    sourceLastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
    

    ' Find cell with word "Emetteurs", search in column R)
    For Each cell In sourceSheet.Range("D1:D" & sourceLastRow).Cells
    

        ' If match
        If cell.Value = "India" Then
            ' Find last row in target sheet based on column "A"
            targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
            ' Copy entire row to next empty row in target sheet
            cell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetLastRow).Offset(RowOffset:=1)
        End If

    Next cell

End Sub

CodePudding user response：

Copy Unique Values (2 columns)

Option Explicit

Sub CopyUniqueValues()

    ' Write the values from the source to an array.

    Dim sws As Worksheet: Set sws = Workbooks("Bookcopy.xlsm").Worksheets("copy")
    
    Dim Data(), srCount As Long, cCount As Long
    
    With sws.Range("A1").CurrentRegion
        srCount = .Rows.Count - 1
        If srCount = 0 Then Exit Sub ' no data
        cCount = .Columns.Count
        Data = .Resize(srCount).Offset(1).Value
    End With
    
    ' Write the unique values from the array to the 'keys' of a dictionary
    ' and their rows of the values' first occurrences to the 'items'.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sr As Long, sString As String
    
    For sr = 1 To srCount
        sString = Data(sr, 4) & "@" & Int(Data(sr, 3))
        If Not dict.Exists(sString) Then dict(sString) = sr
    Next sr
    
    ' Using the rows from the 'items' of the dictionary, write the unique rows
    ' to the top of the array.
    
    Dim sKey, tr As Long, c As Long
    
    For Each sKey In dict.Keys
        sr = dict(sKey)
        tr = tr   1
        For c = 1 To cCount
            Data(tr, c) = Data(sr, c)
        Next c
    Next sKey
    
    ' Reference the target range.
    Dim tws As Worksheet: Set tws = Workbooks("Bookpaste.xlsm").Worksheets("paste")
    Dim tCell As Range: Set tCell = tws.Cells(tws.Rows.Count, "A").End(xlUp).Offset(1)
    Dim trg As Range: Set trg = tCell.Resize(tr, cCount)
    
    ' Write the top rows from the array to the target range.
    trg.Value = Data
    ' Clear below.
    trg.Resize(tws.Rows.Count - trg.Row - tr   1).Offset(tr).ClearContents
    
    ' Inform.
    MsgBox "Unique values copied.", vbInformation

End Sub

CodePudding user response：

you could use Excel built in AutoFilter() and RemoveDuplicates() functionalities

Sub ConditionalRowCopy()

    With Workbooks("Bookcopy.xlsm").Worksheets("copy")
        With .Range("D1", .Cells(.Rows.Count, 1).End(xlUp))
            .AutoFilter Field:=3, Criteria1:=">06/01/2020"
                If Application.Subtotal(103, .Resize(, 1)) > 1 Then
                    .SpecialCells(xlCellTypeVisible).Copy Destination:= Workbooks("Bookpaste.xlsm").Worksheets("paste").Range("A1")
                        With  Workbooks("Bookpaste.xlsm").Worksheets("paste")
                            With .Range("D1", .Cells(.Rows.Count, 1).End(xlUp))
                                .RemoveDuplicates Columns:=Array(3, 4), Header:=xlNo
                            End With
                        End With
                End If
        End With
        .AutoFilterMode = False
    End With
    
End Sub