匹配 2 个工作表之间的日期，然后复制和粘贴特定数据

Question

• 我有 2 个工作表。
• 在 Sh1 中，我在单元格“R2”中输入日期。
• 宏 然后应该在 Sh2 列“C”中搜索匹配项。
• 找到匹配项时 它将从我的比赛下方的 2 个单元格和下面的 74 个单元格复制 在 Sh1 单元格“R3”中粘贴特殊 xlPasteValues。

下面的例子做了类似的事情，但不是想要的结果。

Option Explicit 
Sub FindStr() 

Dim rFndCell As Range 
Dim strData As String 
Dim stFnd As String 
Dim fCol As Integer 
Dim sh As Worksheet 
Dim ws As Worksheet 

Set ws = Sheets("CTN ORIGINAL") 
Set sh = Sheets("Ctn Daily - (enter data here)") 
stFnd = ws.Range("R2").Value 

With sh 
    Set rFndCell = .Range("C:C").Find(stFnd, LookIn:=xlValues) 
    If Not rFndCell Is Nothing Then 
        fCol = rFndCell.Column 
        ws.Range("B3:B33").Copy
        sh.Cells(6, fCol).PasteSpecial xlPasteValues
    Else 'Can't find the item
        MsgBox "No Find" 
    End If 
End With 

End Sub

Answer 1

这里，我给你弄了一个，如果它不起作用，请告诉我。我已经对其进行了测试，它非常适合我。

Option Explicit

Sub findAndCopy()

    Dim foundCell As Range
    Dim strFind As String
    Dim fRow, fCol As Integer
    Dim sh1, sh2 As Worksheet

    'Set sheets
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")

    'Get find string
    strFind = sh1.Range("R2").Value

    'Find string in column C of Sheet2
    Set foundCell = sh2.Range("C:G").Find(strFind, LookIn:=xlValues)

    'If match cell is found
    If Not foundCell Is Nothing Then

        'Get the row and column
        fRow = foundCell.Row
        fCol = foundCell.Column

        'copy data from Sheet2 (from 2 cell below & 74 cells down)
        sh2.Range(Cells(fRow + 2, fCol).Address & ":" & Cells(fRow + 76, fCol).Address).Copy

        'paste in range R3 of Sheet1
        sh1.Range("R3").PasteSpecial xlPasteValues

        'Clear cache
        Application.CutCopyMode = False

    'If not found, show message.
    Else

        Call MsgBox("Not found the match cell!", vbExclamation, "Finding String")

    End If

End Sub