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

I need to be able to use regular expressions in an excel macro that will search through a specific column, and then copy and paste all the rows that contain matches into a new sheet.

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

I have found a script that will search through columns and will paste the matches into a new sheet, but I'm not certain how to modify it use regular expressions instead of a single string.

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

I'm thinking of using this macro to search, but I need to modify the term 'mail box' to be a regular expression term/object, but I'm not sure how to integrate that.

我正在考虑使用这个宏来搜索，但是我需要修改“邮件框”这个词作为一个正则表达式项/对象，但是我不确定如何集成它。

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

2 个解决方案

#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

#2

Without major changes to your existing sub. Replace:

没有对现有潜艇进行重大更改。

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

with:

:

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