searchsheet1中的所有行和列以获取string，如果find，则将整行复制到sheet2

如何searchsheet1中的所有行和列以查找特定string，然后将整行复制到sheet2（如果find），而不会创build重复项？

这是迄今为止我基于这个答案，但我相信我需要循环这个所有列。 这只是search第一列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

我已经重写了你的第一个代码来遍历所有可用的列。 我没有在多个工作表上testing这个代码，但它编译。

 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来pipe理正在考虑的区域，并构build一个数组，以在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), rdCOLs括号括起来Columns:=(rdCOLs),是重要的 。 没有它们，数组不会被.RemoveDuplicates命令处理。 此代码已在Excel 2010上进行了testing。