Regex 搜索和复制行数据VBA

我有一些代码在第二张纸上运行搜索，将匹配的行数据复制到第一张纸的指定位置。 目前，它获取第一行并将信息复制到“工作列表”表中，I A）需要它循环查找A列中具有匹配名称的其他行并将匹配数据粘贴到下面，如果在A列中未找到匹配名称，则搜索B列并复制匹配行数据

这是我到目前为止所拥有的，它是有效的，我只是不能绞尽脑汁研究如何让循环工作。任何帮助都将是伟大的

Sub Filldata()
Dim nxtRow As Integer
ActiveSheet.Unprotect
With Worksheets("Destinations").Range("A:A")

    Set c = .Find(Worksheets("Week Listings").Cells(17, 3).Value, LookIn:=xlValues)
    If c Is Nothing Then
        Range("A20") = "Not Found"
        Range("B20") = "Not Found"
        LCSearch.Hide
        Select Case MsgBox("ESA code entered is invalid, please check. If it aligns with that shown on the order, take action to have the order corrected.", vbOKOnly + vbDefaultButton1, "Error")
            Case vbOK
        End Select
    Else
    ActiveSheet.Unprotect
        mydest = c.Row
              Range("A20") = Worksheets("Destinations").Cells(mydest, 1)
              Range("B20") = Worksheets("Destinations").Cells(mydest, 2)
              Range("C20") = Worksheets("Destinations").Cells(mydest, 3)
              Range("D20") = Worksheets("Destinations").Cells(mydest, 4)
              Range("E20") = Worksheets("Destinations").Cells(mydest, 5)
              Range("F20") = Worksheets("Destinations").Cells(mydest, 6)
              Range("G20") = Worksheets("Destinations").Cells(mydest, 7)
              Range("H20") = Worksheets("Destinations").Cells(mydest, 8)
              LCSearch.Hide
              ActiveSheet.Unprotect
    End If

End With
Worksheets("Week Listings").Range("A20").Select
End Sub

---

不太清楚您所指的第一个和第二个工作表，但从您的代码来看，我相信第一个是目的地，第二个是周列表

下面的代码假设您只对“周清单”！C17中的值感兴趣，并从“周清单”！A20中写入结果，仅搜索目的地中的A、B列：

Sub Filldata()
    On Error Resume Next
    Dim oWS1 As Worksheet, oWS2 As Worksheet
    Dim oRngTmp As Range, oRngSearchFor As Range, oRngSearchData As Range, oRngWriteTo As Range
    Dim i As Long, sTmp As String

    Set oWS1 = ThisWorkbook.Worksheets("Destinations")
    Set oWS2 = ThisWorkbook.Worksheets("Week Listings")
    oWS2.Unprotect

    ' Search for 'Week Listings'!C17
    Set oRngSearchFor = oWS2.Cells(17, 3)
    oRngSearchFor.Value = UCase(oRngSearchFor.Value)

    ' Start cell for writing found data
    Set oRngWriteTo = oWS2.Range("A20")
    sTmp = ""
    ' Setup Search Data, first try Column A
    Set oRngSearchData = oWS1.Columns("A")
    Set oRngTmp = oRngSearchData.Find(oRngSearchFor.Value, LookIn:=xlValues)
    If Not oRngTmp Is Nothing Then
        ' Store first found Address
        sTmp = oRngTmp.Address
        Do
            ' Copy A:H of the matched row to "oRngWriteTo"
            For i = 1 To 8
                oRngWriteTo.Offset(0, i - 1).Value = oWS1.Cells(oRngTmp.Row, i).Value
            Next
            ' Move "oRngWriteTo" to next row
            Set oRngWriteTo = oRngWriteTo.Offset(1, 0)
            Set oRngTmp = oRngSearchData.FindNext(after:=oRngTmp)
        Loop While oRngTmp.Address <> sTmp
    End If

    ' Setup Search Data, next try Column B
    Set oRngSearchData = oWS1.Columns("B")
    Set oRngTmp = oRngSearchData.Find(oRngSearchFor.Value, LookIn:=xlValues)
    If Not oRngTmp Is Nothing Then
        ' Store first found Address
        sTmp = oRngTmp.Address
        Do
            ' Copy A:H of the matched row to "oRngWriteTo"
            For i = 1 To 8
                oRngWriteTo.Offset(0, i - 1).Value = oWS1.Cells(oRngTmp.Row, i).Value
            Next
            ' Move "oRngWriteTo" to next row
            Set oRngWriteTo = oRngWriteTo.Offset(1, 0)
            Set oRngTmp = oRngSearchData.FindNext(after:=oRngTmp)
        Loop While oRngTmp.Address <> sTmp
    End If
    If sTmp = "" Then
        MsgBox "No results Found for " & oRngSearchFor.Value, vbInformation + vbOKOnly
    End If
    oWS2.Protect
    LCSearch.Hide ' Hide UserForm
    ' Clean Up
    Set oRngTmp = Nothing
    Set oRngSearchData = Nothing
    Set oRngSearchFor = Nothing
    Set oRngWriteTo = Nothing
    Set oWS1 = Nothing
    Set oWS2 = Nothing
End Sub

Sub-Filldata（）
出错时继续下一步
将oWS1作为工作表，将oWS2作为工作表
调暗oRngTmp作为范围，ORNGSEARCH作为范围，oRngSearchData作为范围，oRngWriteTo作为范围
Dim i为长，sTmp为字符串
Set oWS1=此工作簿。工作表（“目的地”）
Set oWS2=此工作簿。工作表（“周列表”）
2.取消保护
'搜索'周列表'！C17
设置oRngSearchFor=oWS2。单元格（17,3）
oRngSearchFor.Value=UCase（oRngSearchFor.Value）
'启动单元格以写入找到的数据
设置oRngWriteTo=oWS2.范围（“A20”）
sTmp=“”
'设置搜索数据，首先尝试列A
设置oRngSearchData=oWS1.Columns（“A”）
设置oRngTmp=oRngSearchData.Find（oRngSearchFor.Value，LookIn:=xlValues）
如果不是，那么oRngTmp什么都不是
'存储首次找到的地址
sTmp=oRngTmp.地址
做
'将匹配行的A:H复制到“oRngWriteTo”
对于i=1到8
oRngWriteTo.Offset（0，i-1）.Value=oWS1.Cells（oRngTmp.Row，i）.Value
下一个
'将“oRngWriteTo”移至下一行
设置oRngWriteTo=oRngWriteTo.Offset（1,0）
设置oRngTmp=oRngSearchData.FindNext（后面：=oRngTmp）
当oRngTmp.Address sTmp时循环
如果结束
'设置搜索数据，下一步尝试列B
设置oRngSearchData=oWS1.Columns（“B”）
设置oRngTmp=oRngSearchData.Find（oRngSearchFor.Value，LookIn:=xlValues）
如果不是，那么oRngTmp什么都不是
'存储首次找到的地址
sTmp=oRngTmp.地址
做
'将匹配行的A:H复制到“oRngWriteTo”
对于i=1到8
oRngWriteTo.Offset（0，i-1）.Value=oWS1.Cells（oRngTmp.Row，i）.Value
下一个
'将“oRngWriteTo”移至下一行
设置oRngWriteTo=oRngWriteTo.Offset（1,0）
设置oRngTmp=oRngSearchData.FindNext（后面：=oRngTmp）
当oRngTmp.Address sTmp时循环
如果结束
如果sTmp=“”，则
MsgBox“找不到结果”&oRngSearchFor.Value，vbInformation+vbOKOnly
如果结束
2.保护
LCSearch.Hide“隐藏用户表单”
“清理
设置oRngTmp=无
设置oRngSearchData=Nothing
设置oRngSearchFor=无
将orngwrite设置为=无
设置为1=无
设置为2=无
端接头

---

---

以上代码适用于任何字符串和非精确文本。例如，在搜索“Hamilton”时找不到“Hamilton”（忽略文本前后的空格）。

您好，谢谢您的回答，很抱歉有点含糊。我运行了您的代码，但在oRngWriteTo.Offset（0，I-1）上进行了调试。Value=oWS1.Cells（oRngTmp.Row，I）抱歉，忘了在它们的末尾添加.Value。更新的解决方案。效果很好，谢谢堆！！！！！它现在唯一没有做的事情是在下一行添加两次列出的城市。欢迎用户，“在下一行添加两次列出的城市”？我不知道它们是什么列。下一行如

工作表（“周列表”）.Cells中所示（18,3）

？如果这回答了您原来的问题，请标记已回答以结束问题。