检查 DT Picker 结果，将工作表复制到新工作簿中

Question

我的 VBA 技能不是最好的，如果有人可以在以下方面提供帮助，那就太好了。

我在工作簿中有许多工作表，其单元格区域 E11:E37 中有日期记录。

我正在尝试创建一个报告功能，让用户完成日期选择器用户表单，Excel 在此工作簿的所有工作表中运行上述范围内的搜索，以查找介于 DTPicker1/2 结果之间的日期。

对于返回匹配项的工作表，将所有这些工作表复制到具有名称（“名称和当前日期”.xlsx）的新工作簿。

更新：我尝试将 > 和

更新：代码现在可以工作，但在日期范围 = 01/06/18 - 14/06/18 其中 DTP1 = 07/06/18 和 DTP2 = 16/06/18 的情况下不返回值 true。但在 DTP1 = 04/06/18 和 DTP2 = 08/06/18 的情况下返回 true。

Private Sub CommandButton1_Click()
Dim s As Worksheet, wb As Workbook

For Each s In Worksheets
    If CBool(Application.CountIfs(s.Range("E11:E37"), ">" & 
CDate(DTPicker1.Value), _
                                  s.Range("E11:E37"), "<" & 
CDate(DTPicker2.Value))) Then
        If wb Is Nothing Then
            s.Copy
            Set wb = ActiveWorkbook
        Else
            s.Copy after:=wb.Worksheets(wb.Worksheets.Count)
        End If
    End If
Next s

If wb Is Nothing Then
    MsgBox ("No Records Found")
Else
    wb.SaveAs Filename:="Technicians - Batch Record Report" & Format(Date, 
"ddmmyyyy"), _
          FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
End Sub

Answer 1

试试这个，看看它是否能让你更接近你的目标。

Private Sub CommandButton1_Click()
    Dim s As Worksheet, wb as workbook

    For Each s In workSheets
        If cbool(application.countifs(s.Range("I11:I37"), ">" & cdate(DTPicker1.Value), _
                                      s.Range("I11:I37"), "<" & cdate(DTPicker2.Value))) then
            if wb is nothing then
                s.copy
                set wb = activeworkbook
            else
                s.copy after:=wb.worksheets(wb.worksheets.count)
            end if
        end if
    next s

    if wb is nothing then
        MsgBox ("No Records Found")
    else
        wb.SaveAs Filename:="Technicians - Batch Record Report" & Format(Date, "ddmmyyyy"), _
              FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    End If
End Sub