VBA to extract unique values based on two criteria and paste it to another sheet

[asad]

Hello All,

After going through numerous posts, I have managed to put the following code together that helps me in extracting unique values from Sheet 1 Column C into Sheet 2 column A. What I am trying to add is a condition for unique values only for a date that user will be asked to enter. I am at a loss how to get this done. Have tried looking for the answer in different posts but no luck so far. The dates are in Column A of Sheet 1 and are in the format of dd/mm/yyyy hh:mm. The code is as following thus far.

Sub Test()

Dim rw As Long, lrw As Long, lrw2 As Long
Dim rSrc As Range
 
rw = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
Set rSrc = Worksheets("Sheet1").Range("C2:C" & rw)
 
rSrc.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Z1"), Unique:=True
lrw = Worksheets("Sheet1").Cells(Rows.Count, "Z").End(xlUp).Row


For Each Cell In Worksheets("Sheet1").Range("Z1:Z" & lrw)
    If Cell.Value > 600 Then
        Cell.ClearContents
    End If
Next
    Worksheets("Sheet1").Sort.SortFields.Clear
    Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("Z1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With Worksheets("Sheet1").Sort
        .SetRange Range("Z1:Z" & lrw)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        Range("Z1").Select
    End With
lrw2 = Worksheets("Sheet1").Cells(Rows.Count, "Z").End(xlUp).Row
    Sheets("Sheet1").Range("Z2:Z" & lrw2).Copy Sheets("Sheet2").Range("A6")


Sheets("Sheet1").Range("Z1:Z" & lrw2).ClearContents


End Sub

Any help will be greatly appreciated.

Asad

 

[asad]

I tried the one below, but it did not work.

Sub Test()

Dim rw As Long, lrw As Long, lrw2 As Long
Dim rSrc As Range, dt As Date
dt = InputBox("Please enter date in dd/mm/yyyy format")
rw = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
Set rSrc = Worksheets("Sheet1").Range("C2:C" & rw)
 
[COLOR=#ff0000]rSrc.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("A2:A" & rw) = dt, CopyToRange:=Range("Z1"), Unique:=True[/COLOR]
lrw = Worksheets("Sheet1").Cells(Rows.Count, "Z").End(xlUp).Row


For Each Cell In Worksheets("Sheet1").Range("Z1:Z" & lrw)
    If Cell.Value > 600 Then
        Cell.ClearContents
    End If
Next
    Worksheets("Sheet1").Sort.SortFields.Clear
    Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("Z1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With Worksheets("Sheet1").Sort
        .SetRange Range("Z1:Z" & lrw)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        Range("Z1").Select
    End With
lrw2 = Worksheets("Sheet1").Cells(Rows.Count, "Z").End(xlUp).Row
    Sheets("Sheet1").Range("Z2:Z" & lrw2).Copy Sheets("Sheet2").Range("A6")


Sheets("Sheet1").Range("Z1:Z" & lrw2).ClearContents


End Sub

The line in Red gets highlighted.

 

[asad]

Hi All,

I got the following code to do what I wanted, except for one small issue. I have three codes in column H - AP, SX, and AVA. I am trying to get unique values only if column H has AP or SX. All the unique values that have AVA in column H must be ignored. Is it possible?

Sub Ladder()

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim rw As Long, lrw As Long, lrw2 As Long, frw As Long
Dim rSrc As Range, sdt As Date, edt As Date, mdt As Date


    Worksheets("Master Ticket Sales").Activate
        pw = InputBox("Please enter passowrd to run this code")
            If pw = "bus" Then
                sdt = Worksheets("Ticket Sales Ladder - Weekly").Range("C1").Value
                mdt = WorksheetFunction.Max(Sheets("Master Ticket Sales").Range("G:G"))
                edt = WorksheetFunction.Min(mdt, Worksheets("Ticket Sales Ladder - Weekly").Range("B1").Value)
                    Range("Q1").Value = Range("C1").Value
                    Range("P1").Value = Range("B1").Value
                        rw = Worksheets("Master Ticket Sales").Range("A:A").Find(what:=edt, LookIn:=xlValues, lookat:=xlPart, Searchdirection:=xlPrevious).Row
                        frw = Worksheets("Master Ticket Sales").Range("A:A").Find(what:=sdt, LookIn:=xlValues, lookat:=xlPart, SearchOrder:=xlByRows).Row
                            Set rSrc = Worksheets("Master Ticket Sales").Range("C" & frw & ":C" & rw)
 
                            rSrc.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Z1"), Unique:=True
                            lrw = Worksheets("Master Ticket Sales").Cells(Rows.Count, "Z").End(xlUp).Row


                                For Each Cell In Worksheets("Master Ticket Sales").Range("Z1:Z" & lrw)
                                    If Cell.Value > 600 Then
                                        Cell.ClearContents
                                    End If
                                Next
                
                    Worksheets("Master Ticket Sales").Sort.SortFields.Clear
                    Worksheets("Master Ticket Sales").Sort.SortFields.Add2 Key:=Range("Z1"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                    xlSortTextAsNumbers
    
                        With Worksheets("Master Ticket Sales").Sort
                            .SetRange Range("Z1:Z" & lrw)
                            .Header = xlNo
                            .MatchCase = False
                            .Orientation = xlTopToBottom
                            .SortMethod = xlPinYin
                            .Apply
                            Range("Z1").Select
                        End With


                                Sheets("Master Ticket Sales").Range("Z2:Z46").Copy
                                Sheets("Ticket Sales Ladder - Weekly").Select
                                    Range("A5").Select
                                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                    :=False, Transpose:=False
                                    
                    Worksheets("Ticket Sales Ladder - Weekly").Range("A5:A49").Copy Worksheets("Ticket Sales Ladder - Weekly").Range("O5:O49")
                    Worksheets("Ticket Sales Ladder - Weekly").Range("C1").Select
                    Sheets("Master Ticket Sales").Range("Z1:Z46").ClearContents

Else: Exit Sub
End If
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With


End Sub