Excel正则表达式宏，它将搜索一列匹配项，并将所有匹配项的整个行粘贴到另一工作表中

Question

我需要能够在excel宏中使用正则表达式，该宏将搜索特定的列，然后将包含匹配项的所有行复制并粘贴到新表中。

我找到了一个脚本，该脚本将搜索列并将匹配项粘贴到新的工作表中，但是我不确定如何使用正则表达式而不是单个字符串进行修改。

我正在考虑使用此宏进行搜索，但是我需要将术语“邮箱”修改为正则表达式术语/对象，但是我不确定如何将其集成。

Sub SearchForString()

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer

   On Error GoTo Err_Execute

   'Start search in row 4
   LSearchRow = 4

   'Start copying data to row 2 in Sheet2 (row counter variable)
   LCopyToRow = 2

   While Len(Range("A" & CStr(LSearchRow)).Value) > 0

      'If value in column E = "Mail Box", copy entire row to Sheet2
      If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

         'Select row in Sheet1 to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy

         'Paste row into Sheet2 in next row
         Sheets("Sheet2").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         'Move counter to next row
         LCopyToRow = LCopyToRow + 1

         'Go back to Sheet1 to continue searching
         Sheets("Sheet1").Select

      End If

      LSearchRow = LSearchRow + 1

   Wend

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub

Err_Execute:
   MsgBox "An error occurred."

End Sub

Answer 1

Sub SearchForString()

    Dim RE As Object
    Dim LSearchRow As Long
    Dim LCopyToRow As Long

    On Error GoTo Err_Execute

    Set RE = CreateObject("vbscript.regexp")
    RE.Pattern = "(red|blue)"
    RE.Ignorecase = True

    LSearchRow = 4 'Start search in row 4
    LCopyToRow = 2 'Start copying data to row 2 in Sheet2 (row counter variable)

    While Len(Cells(LSearchRow, "A").Value) > 0

     If RE.Test(Cells(LSearchRow, "E").Value) Then
         ActiveSheet.Rows(LSearchRow).Copy Sheets("Sheet2").Rows(LCopyToRow)
         LCopyToRow = LCopyToRow + 1 'Move counter to next row
     End If

     LSearchRow = LSearchRow + 1

    Wend

    Range("A3").Select 'Position on cell A3
    MsgBox "All matching data has been copied."

    Exit Sub

Err_Execute:
    MsgBox "An error occurred."

End Sub

Answer 2

无需对现有子项进行重大更改。 更换：

If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

有：

v = Range("E" & CStr(LSearchRow)).Value
If InStr(1, v, "red") > 0 Or InStr(1, v, "blue") > 0 Then