Excel VBA - 搜索日期并将特定单元格复制到另一个工作表答案

【问题标题】：Excel VBA - Search for dates and copy specific cells to another sheetExcel VBA - 搜索日期并将特定单元格复制到另一个工作表
【发布时间】：2018-07-25 00:39:36
【问题描述】：

我有以下代码，它是由以前的同事编写的，我需要帮助修改它。

加载用户表单，用户输入开始/结束日期。它在工作表 1 中搜索此开始/结束范围内的日期，然后将该整行复制到工作表 2，并继续向下工作表 1 搜索匹配的日期。

我需要修改为

在Sheet1、Q 列和S 中搜索日期
在同一行中复制Sheet1 单元格C、G、J 和日期Q 和S
粘贴到Sheet2 上A、B、C、D 和E 列中的一行。

这超出了我的知识水平。任何帮助将不胜感激，因为我似乎无法弄清楚这段代码。如果你能用简单的语言解释它是如何工作的，那同样很棒！

Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range '-- this is used to store the single cell in the For Each loop

    Set shtSrc = Sheets("Sheet1") ' Sets "Sheet1" sheet as source sheet
    Set shtDest = Sheets("Sheet2") 'Sets "Sheet2." sheet as destination sheet
    destRow = 5 'Start copying to this row on destination sheet

' >> Set range to search for dates in Look Ahead period <<
    Set rng = Application.Intersect(shtSrc.Range("P:P"), shtSrc.UsedRange)

' >> Look for matching dates in columns C to D <<
    For Each c In rng.Cells
        If (c.value >= startDate And c.value <= endDate) Or _
    (c.Offset(0, 1).value >= startDate And c.Offset(0, 1).value <= endDate) Then ' Does date fall between start and end dates? If Yes, then copy to destination sheet

            c.Offset(0, -2).Resize(1, 12).Copy _
                          shtDest.Cells(destRow, 1) 'Copy a 12 cell wide block to the other sheet, paste into Column A on row destRow
            destRow = destRow + 1

' > Ends search for dates <
        End If
    Next

【问题讨论】：

标签： vba excel

【解决方案1】：

使用此代码，它应该可以工作：

Dim rng As Range, destRow As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim c As Range '-- this is used to store the single cell in the For Each loop

Set shtSrc = Sheets("Sheet1") ' Sets "Sheet1" sheet as source sheet
Set shtDest = Sheets("Sheet2") 'Sets "Sheet2." sheet as destination sheet
destRow = 5 'Start copying to this row on destination sheet

' >> Set range to search for dates in Look Ahead period <<
Set rng = Application.Intersect(shtSrc.Range("Q:Q"), shtSrc.UsedRange)

' >> Look for matching dates in columns C to D <<
For Each c In rng.Cells
    If (c.Value >= StartDate And c.Value <= EndDate) Or _
(c.Offset(0, 2).Value >= StartDate And c.Offset(0, 2).Value <= EndDate) Then ' Does date fall between start and end dates? If Yes, then copy to destination sheet

        shtSrc.Range("C" & c.Row).Copy shtDest.Range("A" & destRow)
        shtSrc.Range("G" & c.Row).Copy shtDest.Range("B" & destRow)
        shtSrc.Range("J" & c.Row).Copy shtDest.Range("C" & destRow)
        shtSrc.Range("Q" & c.Row).Copy shtDest.Range("D" & destRow)
        shtSrc.Range("S" & c.Row).Copy shtDest.Range("E" & destRow)

        destRow = destRow + 1

' > Ends search for dates <
    End If
Next

【讨论】：

【解决方案2】：

由于这是一个“Excel-as-datasource”问题，我会为此使用 SQL 语句。添加对 Microsoft ActiveX Data Objects 6.1 Library 的引用（通过 Tools -> References...）。可能有 6.1 以外的版本；选择最高的。

Dim pathToExcelFile As String
pathToExcelFile = ActiveWorkbook.Name

Dim cmd As New ADODB.Command
cmd.ActiveConnection = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & pathToExcelFile & """;" & _
    "Extended Properties=""Excel 12.0;HDR=No"""

'This string defines which data we are retrieving from the source worksheet
'SELECT F3, F7, F10, F17, F19 -- choose the columns C, G, J, Q and S
'FROM [Sheet1$] -- from Sheet1
'WHERE ... -- where F17 (Column Q) is between the start and end date;
'    we'll fill in the values corresponding to the question marks later
'OR ... -- or F19 (Column S) is between the start and end date

cmd.CommandText = _
    "SELECT F3, F7, F10, F17, F19 " & _
    "FROM [Sheet1$] " & _
    "WHERE F17 BETWEEN ? AND ? " & _
       "OR F19 BETWEEN ? AND ?"

Dim startParameter As ADODB.Parameter
Set startParameter = cmd.CreateParameter("StartDate", adDate, adParamInput, , StartDate)

Dim endParameter As ADODB.Parameter
Set endParameter = cmd.CreateParameter("EndDate", adDate, adParamInput, , EndDate)

'We're filling in the question marks here
'1st and 3rd -- start date
'2nd and 4th -- end date
cmd.Paramters.Append startParameter
cmd.Parameters.Append endParameter
cmd.Paramters.Append startParameter
cmd.Parameters.Append endParameter

Dim rs As ADODB.Recordset
Set rs = cmd.Execute

'Paste the resulting data starting from A5
Worksheets("Sheet2").Range("A5").CopyFromRecordset(rs)

参考文献

ActiveX 数据对象

Excel

【讨论】：