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

1 个答案: