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

Question

• 我有2张工作单。
• 在Sh1中，我在Cell'R2'中输入日期。
• 然后宏应搜索Sh2列'C'以进行匹配。
• 当找到匹配时，它将从我的匹配下面的2个单元格和74个单元格中复制，然后在Sh1单元格“R3”中复制PasteSpecial 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