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

Question

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

加载用户表格，并且用户输入开始/结束日期。 它在Sheet 1中搜索此开始/结束范围内的日期，然后将整个行复制到Sheet2，然后继续在Sheet1中向下搜索匹配的日期。

我需要对此进行修改

1. 在Sheet1 Q和S列中搜索日期
2. 在同一行中复制Sheet1单元格C ， G ， J以及日期Q和S
3. 粘贴到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

Answer 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

Answer 2

由于这是一个“ Excel-as-datasource”问题，因此我将使用一条SQL语句。 添加对Microsoft ActiveX数据对象6.1库的引用（通过工具 -> 引用... ）。 可能有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数据对象

• 命令对象 ， ActiveConnection属性 ， CommandText属性 ， CreateParameter方法
• 参数收集 ， 追加方法
• 记录集对象

电子表格

• 工作表集合
• 工作表对象 ， Range属性 ， Cells属性
• 范围对象 ， CopyFromRecordset方法 ， TextToColumns方法 ， Value属性