VBA Excel, чтобы выбрать диапазон, только если текущая дата существует

Question

Я пытаюсь скомпилировать код, который будет получать данные из каждого листа в книге, которая называется Employee, и вытащить данные, которые имеют только текущую дату в столбце «O», однако у меня возникают проблемы с добавлением поля критериев, и я, вероятно, просто не делаю этого правильно.

Sub x() 

    Dim NewWB As Excel.Workbook 
    Dim ws As Excel.Worksheet 
    Dim r As Excel.Range 
    Dim r2 As Excel.Range 

    Set NewWB = Workbooks.Add 

    ThisWorkbook.Sheets(6).Range("B1:O1").Copy NewWB.Sheets(1).Range("A1") 

    For Each ws In ThisWorkbook.Worksheets 

     If ws.name Like "Employee*" Then 

     Set r = ws.Range("B2", ws.Range("O" & ws.UsedRange.Rows.count) Field:=15, Criteria1:=">=" & Date) 

     r.Copy 

     Set r2 = NewWB.Sheets(1).Range("A" & Rows.count).End(xlUp).Offset(1) 

     r2.PasteSpecial Paste:=xlValues 
     r2.PasteSpecial Paste:=xlPasteColumnWidths 
     r2.PasteSpecial Paste:=xlPasteValues 
     r2.PasteSpecial Paste:=xlPasteFormats 
     r2.Offset(, 14).Resize(r.Rows.count).Value = ws.name 
    End If 
Next 

End Sub 

Спасибо!

Answer 1

Похоже, вы пытаетесь использовать AutoFilter, но мы можем использовать его только для организации данных перед его копированием. Информация здесь действительно полезна: http://www.ozgrid.com/VBA/autofilter-vba.htm. Затем нам нужно задать диапазон вновь фильтруются диапазон перед копированием:

Sub x() 

Dim NewWB As Excel.Workbook 
Dim ws As Excel.Worksheet 
Dim r As Excel.Range 
Dim r2 As Excel.Range 

Set NewWB = Workbooks.Add 

'Not sure what this is for or if you need this 
ThisWorkbook.Sheets(6).Range("B1:O1").Copy NewWB.Sheets(1).Range("A1") 

For Each ws In ThisWorkbook.Worksheets 

    If ws.Name Like "Employee*" Then 

     ws.AutoFilterMode = False 

     Dim filterRange As Excel.Range 

     Set filterRange = ws.Range("B2", ws.Range("O" & ws.UsedRange.Rows.Count)) 

     filterRange.AutoFilter 
     filterRange.AutoFilter _ 
      Field:=14, _ 
      Criteria1:=">=" & Date 

     'Set to the cells that aren't filtered out 
     Set r = filterRange.Rows.SpecialCells(xlCellTypeVisible) 

     r.Copy 

     Set r2 = NewWB.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1) 

     r2.PasteSpecial Paste:=xlValues 
     r2.PasteSpecial Paste:=xlPasteColumnWidths 
     r2.PasteSpecial Paste:=xlPasteValues 
     r2.PasteSpecial Paste:=xlPasteFormats 
     r2.Offset(, 14).Resize(r.Rows.Count).Value = ws.Name 

     ws.AutoFilterMode = False 'remove filter after you're done 

    End If 
Next 

End Sub 

EDIT: Мы были на ложном пути. AutoFilter не возвращает диапазон, он устанавливает AutoFilter в диапазон. Извините за то, что вы сбились с пути, единственное место, где я видел «Поле:» и «Критерии1:», используется для AutoFilter. Но я вижу, как он используется здесь, AutoFilter Return, и переработал мое сообщение в том, что я думаю, сделаю трюк.

EDIT: обнаружена ошибка. В нашем отфильтрованном диапазоне нет 15 полей. Просто 14. Добавлен полный Sub для ответа.