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

debugcn 发表于 Dev

utt73

我将如何在sheet1的所有行和列中搜索特定的字符串，然后将整个行复制到sheet2（如果找到），而不创建重复项？

到目前为止，这是我根据此答案得出的结论，但我认为我需要针对所有列进行循环。这只是在搜索第一列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

用户4039065

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

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

rdCOL中的括号Columns:=(rdCOLs),很重要。没有它们，该.RemoveDuplicates命令将不会处理该数组。此代码已在Excel 2010上进行了测试。

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。