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

Question

在我的 Excel 文件中，我想实现自定义搜索。因此，我创建了一个名为“搜索”的工作表 - 在这张表上，我放置了一个文本框、一个按钮和一个简短的信息文本。 目前我检查每个工作表并复制第二行（我的列的标题），然后我将每个单元格的文本与搜索词进行比较，如果我找到匹配项，我将复制找到匹配项的行。

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

但是当一个单词在一行中出现多次时，此代码将多次复制该行。如果找到匹配项，如何跳转到下一行？

很高兴有任何帮助或想法

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

请注意，此代码还会搜索您的搜索工作表，您可能希望在搜索中省略该工作表。

Answer 2

下面的答案将：

1. 搜索WorkBook中放置代码的所有工作表，Sheet("Search")除外。
2. 在每个Sheets 中，它将贯穿每个Row 并寻找searchword。如果它在该行中找到单词，它会将整行复制到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 代码，以备不时之需，但此代码不需要使用它来复制每张工作表中包含搜索词的每一行。