Excel / VBA遍历工作表中的每个单元格，比较值，将行复制到另一个工作表

在我的Excel文件中，我想实现一个自定义search。 因此，我创build了一个名为“search”的工作表 – 在这个表上我放置了一个TextBox，一个button和一个简短的信息文本。 此刻，我翻遍每个工作表并复制第二行（我的专栏的标题），然后比较每个单元格的文本与search词，如果我得到一个匹配，我将复制行，在那里我find了匹配。

Private Sub SearchButton_Click() Application.DisplayAlerts = False Dim searchword As String searchword = Worksheets("Search").SearchTextBox.Text If Len(Trim(searchword)) > 0 Then Worksheets("Search").Cells.Delete Dim i As Long i = 5 Dim found As Boolean For Each Worksheet In ActiveWorkbook.Worksheets Worksheet.Range("A2").EntireRow.Copy Worksheets("Search").Cells(i, 1) i = i + 1 found = False For Each cell In Worksheet.UsedRange.Cells If InStr(cell.Text, searchword) > 0 Then cell.EntireRow.Copy Worksheets("Search").Cells(i, 1) found = True i = i + 1 End If Next If found = True Then i = i + 4 Else Worksheets("Search").Rows(i - 1).Delete End If Next Else MsgBox "Empty TextBox!", vbOKOnly, "Error" End If Application.DisplayAlerts = True End Sub 

但是，当一个单词在一行中多次时，这个代码将复制这个行多次。 如果find一场比赛我怎么能跳到下一排？

我很高兴有任何帮助或想法

Answer 1

你可以这样做：

 Private Sub SearchButton_Click() Application.DisplayAlerts = False Dim searchword As String searchword = Worksheets("Search").SearchTextBox.Text If Len(Trim(searchword)) > 0 Then Worksheets("Search").Cells.Delete Dim i As Long i = 5 Dim found As Boolean For Each Worksheet In ActiveWorkbook.Worksheets Worksheet.Range("A2").EntireRow.Copy Worksheets("Search").Cells(i, 1) i = i + 1 found = False For Each Row In Worksheet.UsedRange.Rows For Each cell In Row.Cells If InStr(cell.Text, searchword) > 0 Then cell.EntireRow.Copy Worksheets("Search").Cells(i, 1) found = True i = i + 1 Exit For End If Next Next If found = True Then i = i + 4 Else Worksheets("Search").Rows(i - 1).Delete End If Next Else MsgBox "Empty TextBox!", vbOKOnly, "Error" End If End Sub 

请注意，此代码还会search您的search工作表，您可能希望忽略该表单的search。

Answer 2

答案如下：

1. search工作WorkBook中放置代码的所有工作表，“ Sheet("Search") 。
2. 在每个Sheets ，它将遍历每一Row并寻找searchsearchword 。 如果在该行中find该单词，则会将整行复制到工作Sheet("Search") 。 然后它将移动到该工作Sheet的下一行。

看下面的代码：

 Option Explicit Private Sub SearchButton_Click() 'Application.DisplayAlerts = False Dim CurrentSheet As Worksheet Dim LastRow As Long Dim CurrentRow As Long Dim LastColumn As Long Dim searchword As String Dim TextFoundRng As Range searchword = Worksheets("Search").SearchTextBox.Text If Len(Trim(searchword)) > 0 Then Worksheets("Search").Cells.Delete Dim i As Long i = 5 Dim found As Boolean 'Using this WorkBook instead of Active, incase another workbook is activated For Each CurrentSheet In ThisWorkbook.Worksheets If CurrentSheet.Name = "Search" Then Else With CurrentSheet LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column End With 'i = i + 1 'found = False For CurrentRow = 2 To LastRow Set TextFoundRng = CurrentSheet.Range(CurrentSheet.Cells(CurrentRow, 2), _ CurrentSheet.Cells(CurrentRow, LastColumn)).Find(What:=searchword) 'When TextFoundRng <> nothing, it means found something' If Not TextFoundRng Is Nothing Then CurrentSheet.Rows(CurrentRow).EntireRow.Copy Destination:=ThisWorkbook.Sheets("Search").Range("A" & Rows.Count).End(xlUp).Offset(1) End If Next CurrentRow 'For Each cell In CurrentSheet.UsedRange.Cells ' ' If InStr(cell.Text, searchword) > 0 Then ' cell.EntireRow.Copy CurrentSheet("Search").Cells(i, 1) ' found = True ' i = i + 1 ' End If ' 'Next 'If found = True Then ' i = i + 4 'Else ' Worksheets("Search").Rows(i - 1).Delete 'End If End If Next CurrentSheet Else MsgBox "Empty TextBox!", vbOKOnly, "Error" End If 'Application.DisplayAlerts = True End Sub 

我已经保存了您的Found和i代码，以防其他事情需要它，但是这段代码不需要使用它来复制每一行都有来自每个工作表的search词。