Criteria range for advance filter not working.

Heya,

I'm trying to copy data thru VBA. Specifically, I want to copy only those rows whose corresponding cell in the date column (column "A") has the month text that I'm looking for in a specific cell range - the Criteria Range. In this case, it'd be cell "Z1". If "Z1" says April, then only copy those rows whose date column contained a corresponding date containing the string "April". The macro is run from a macro file with a button and a field where the month name is entered. The copying is done from a separate file.

Right now, the copying seems to be working fine but regardless of what I type in Z1 as the Criteria Range, I still get ALL rows. I'm not sure what the issue is.

Here is the code. I'm trying to solve something that was left over from a colleague who left, and they didn't comment, nor apply proper naming conventions but I still hope it will be readable. I will definitely correct this as soon as this issue is resolved.

Option Explicit

Sub Button1_Click()
    Dim MyPath As String
    Dim MyName As String
    Dim wk As Workbook
    Dim r As Range
    Dim get_mo As String
    Dim iEnd As Integer
    Dim sh As Worksheet
    Dim shThis As Worksheet
    Dim wkThis As Workbook
    Set wkThis = ThisWorkbook
    Set shThis = wkThis.Worksheets("Sheet1")
    get_mo = shThis.Range("C2").Value
    shThis.Range("C8:L" & shThis.Range("C" & Rows.Count).End(xlUp).Row + 1).ClearContents
    MyPath = wkThis.Path & "\"
    MyName = Dir(MyPath, vbDirectory)
    Application.ScreenUpdating = False
    Do While MyName <> ""
        If Right(MyName, 4) = "xlsx" Then
            If MyName <> wkThis.Name Then
                Set wk = Workbooks.Open(MyPath & MyName)
                Set sh = wk.Worksheets(1)
                sh.Range("Y1").Value = "Date"
                sh.Range("Z1").Value = get_mo
                sh.Range("L1:U1").Value = Array("Date", "Last Name", "First Name", "Log #") 'note that some items removed from array. Shouldn't affect anything.
                sh.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=sh.Range("Z1"), CopyToRange:=sh.Range("L1:U1"), Unique:=False
                Set r = sh.Range("L1").CurrentRegion
                If r.Rows.Count > 1 Then
                    Set r = r.Offset(1).Resize(r.Rows.Count - 1)
                    iEnd = shThis.Range("C" & Rows.Count).End(xlUp).Row + 1
                    shThis.Range("C" & iEnd).Resize(r.Rows.Count, 10).Value = r.Value
                End If
                'wk.Close False
            End If
        End If
        MyName = Dir
    Loop
    iEnd = shThis.Range("C" & Rows.Count).End(xlUp).Row
    shThis.Range("C7:L" & iEnd).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End Sub

Any help would be appreciated. Thanks!

Thanks for the reply lecxe!

I see. I've made the changes to the code, but unfortunately I'm still getting all rows copied instead of only the rows that should contain the month in question. I'm now using rows Y1:Y2 where Y1 is "Date" and Y2 is the month text.

Here is the updated code:

Option Explicit

Sub Button1_Click()
    Dim MyPath As String
    Dim MyName As String
    Dim wk As Workbook
    Dim r As Range
    Dim get_mo As String
    Dim iEnd As Integer
    Dim sh As Worksheet
    Dim shThis As Worksheet
    Dim wkThis As Workbook
    Set wkThis = ThisWorkbook
    Set shThis = wkThis.Worksheets("Sheet1")
    get_mo = shThis.Range("C2").Value
    shThis.Range("C8:L" & shThis.Range("C" & Rows.Count).End(xlUp).Row + 1).ClearContents
    MyPath = wkThis.Path & "\"
    MyName = Dir(MyPath, vbDirectory)
    Application.ScreenUpdating = False
    Do While MyName <> ""
        If Right(MyName, 4) = "xlsx" Then
            If MyName <> wkThis.Name Then
                Set wk = Workbooks.Open(MyPath & MyName)
                Set sh = wk.Worksheets(1)
                sh.Range("Y1").Value = "Date"
                sh.Range("Y2").Value = get_mo
                sh.Range("L1:U1").Value = Array("Date", "Last Name", "First Name", "Log #")  'note that some items removed from array. Shouldn't affect anything.
                sh.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=sh.Range("Y1:Y2"), CopyToRange:=sh.Range("L1:U1"), Unique:=False
                Set r = sh.Range("L1").CurrentRegion
                If r.Rows.Count > 1 Then
                    Set r = r.Offset(1).Resize(r.Rows.Count - 1)
                    iEnd = shThis.Range("C" & Rows.Count).End(xlUp).Row + 1
                    shThis.Range("C" & iEnd).Resize(r.Rows.Count, 10).Value = r.Value
                End If
                'wk.Close False
            End If
        End If
        MyName = Dir
    Loop
    iEnd = shThis.Range("C" & Rows.Count).End(xlUp).Row
    shThis.Range("C7:L" & iEnd).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End Sub