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屬性