在 sheet1 中的所有行和列中搜索字符串，如果找到则将整行复制到 sheet2

Question

我如何在 sheet1 中的所有行和列中搜索特定字符串，然后在不创建重复项的情况下将整行复制到 sheet2？

这是我目前所拥有的based upon this answer，但我相信我需要对所有列进行循环。这只是搜索第一列 A.

Sub Main()
   Dim wb1 As Workbook
   Set wb1 = ThisWorkbook

   Call searchtext("organic", "Organic Foods")
   wb1.Save

End Sub


Private Sub searchtext(term, destinationsheet)
    Dim wb1 As Workbook
    Set wb1 = ThisWorkbook
    Dim ws1 As Worksheet
    Set ws1 = wb1.Sheets(1) 'assumes raw data is always first sheet
    Dim ws2 As Worksheet
    Dim copyFrom As Range
    Dim lRow As Long 

    With ws1

        .AutoFilterMode = False

        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A1:A" & lRow)
            .AutoFilter Field:=1, Criteria1:="=*" & term & "*"
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        .AutoFilterMode = False
    End With

    '~~> Destination File
    Set ws2 = wb1.Worksheets(destinationsheet)

    ws2.Cells.ClearContents

    With ws2
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lRow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            lRow = 1
        End If

        copyFrom.Copy .Rows(lRow)
    End With


End Sub

当我尝试先循环再去重时，下面的代码只比较了前两列。如何指定要比较重复项的所有列？

Private Sub RemoveDuplicates(destinationsheet) 
    Dim wb1 As Workbook
    Set wb1 = ThisWorkbook

    With wb1.Worksheets(destinationsheet)
        Set Rng = Range("A1", Range("B1").End(xlDown))
        Rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    End With

End Sub

Answer 1

我已经重写了您的第一个代码以遍历所有可用列。我没有在多个工作表上测试此代码，但它确实可以编译。

Private Sub searchtext(term, destinationsheet)
    Dim wb1 As Workbook, ws1 As Worksheet, ws2 As Worksheet
    Dim copyFrom As Range, c As Long, lr As Long, b1st As Boolean

    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Worksheets(1) 'assumes raw data is always first sheet
    Set ws2 = wb1.Worksheets(destinationsheet)
    ws2.Cells.ClearContents

    With ws1.Cells(1, 1).CurrentRegion
        .Parent.AutoFilterMode = False
        lr = .Rows.Count
        For c = 1 To .Columns.Count
            b1st = CBool(Application.CountA(ws2.Columns(1)))
            .AutoFilter
            .Columns(c).AutoFilter Field:=1, Criteria1:="=*" & term & "*"
            If CBool(Application.Subtotal(103, .Columns(c))) Then _
                .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Copy _
                    Destination:=ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0 - b1st, 0)
        Next c

        .Parent.AutoFilterMode = False
    End With

    Set ws2 = Nothing
    Set ws1 = Nothing
    Set wb1 = Nothing
End Sub

关于您的删除重复项问题，请使用 .CurrentRegion 管理正在考虑的区域并构建一个数组以在 Columns:= 参数中使用。

Public Sub RemoveDuplicates(destinationsheet)
    Dim a As Long, rdCOLs As Variant
    Dim wb1 As Workbook
    Set wb1 = ThisWorkbook

    With wb1.Worksheets(destinationsheet)
        With .Cells(1, 1).CurrentRegion
            ReDim rdCOLs(.Columns.Count - 1)
            For a = LBound(rdCOLs) To UBound(rdCOLs)
                rdCOLs(a) = a + 1
            Next a
            .RemoveDuplicates Columns:=(rdCOLs), Header:=xlYes
        End With
    End With

    Set wb1 = Nothing
End Sub

Columns:=(rdCOLs), 中 rdCOL 周围的括号重要。没有它们，数组就不会被 .RemoveDuplicates 命令处理。此代码已于 Excel 2010 年测试。

在 sheet1 中的所有行和列中搜索字符串，如果找到则将整行复制到 sheet2

search all rows and columns in sheet1 for string, copy entire row to sheet2 if found

excel

vba

find