Question

我有2张工作单。
在Sh1中，我在Cell＆＃39; R2＆＃39;中输入日期。
宏然后应该搜索Sh2列＆＃39; C＆＃39;比赛。
找到匹配项它将从我的匹配＆amp;下面的2个单元格中复制出来然后是74个细胞在Sh1 Cell＆＃39; R3＆＃39;。

下面的示例执行类似但不是所需的结果。

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个工作表之间的日期，然后复制并粘贴特定数据

1 个答案: