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

Question

我有2张工作表。
在 Sh1 中，我在单元格 'R2' 中输入日期。
宏然后应该在 Sh2 列 'C' 中搜索匹配项。
找到匹配项时它将从我的比赛下方的 2 个单元格复制然后向下复制 74 个单元格 Sh1 单元格中的 PasteSpecial xlPasteValues 'R3'。

下面的示例做了类似的事情，但不是预期的结果。

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

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

Match a Date between 2 Worksheets then Copy and Paste Specific Data

excel

find

copy-paste

worksheet-function

vba