获取用户指定的列表，并在充满excel文件的文件夹中搜索所有文本实例

Question

我有以下代码，用户输入包含excel文件的文件夹，然后是指定“关键字”或“Dirty-Word”搜索的另一个输入。我无法用它来搜索单词搜索的每个实例。它会搜索所有文件，并且正在查找正确的实例，但不会引发多个匹配。我有一个测试文件夹，其中包含多个简单的excel 2013工作簿，其中包含少量具有重复文本的单元格。循环似乎正常工作，但我如何让它显示所有匹配而不仅仅是第一个？

Sub WordSearch()
Dim WS As Worksheet
Dim Testfolder As String
Dim a As Single
Dim sheet As Worksheet
Dim CheckReport As Variant
Dim CheckLength As Long
Dim Wordcheck As String
Dim Checksheet As Object

Set WS = Sheets.Add

' Open file folder for excel files
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Testfolder = .SelectedItems(1) & "\"
End With

'Open the target workbook
CheckReport = Application.GetOpenFilename("Excel-files,*.xls*", _
1, "Select Your CheckList File To Open", , False)

' Create Header and information for final sheet
WS.Range("A1") = "Path"
WS.Range("B1") = Testfolder
WS.Range("A2") = "CheckList:"
WS.Range("B2") = CheckReport
WS.Range("A4") = "Matched Word"
WS.Range("B4") = "Workbook"
WS.Range("C4") = "Worksheet"
WS.Range("D4") = "Cell Address"
WS.Range("E4") = "Link"

Cells.EntireColumn.AutoFit

Files = Dir(Testfolder)

'Set loop to search all files in the designated folder
Do Until Files = ""

    If Files = "." Or Files = ".." Then
    MsgBox "No Excel files found"

    Else
        If Right(Files, 3) = "xls" Or Right(Files, 4) = "xlsx" Or Right(Files, 4) = "xlsm" Then
            On Error Resume Next
            Workbooks.Open Filename:=Testfolder & Files, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
                WS.Range("B5").Offset(a, 0).Value = Files
                WS.Range("C5").Offset(a, 0).Value = "Password protected"
                a = a + 1

                On Error GoTo 0
            Else

            ' Open the CheckSheet to let loop count and get search words
            Set Checksheet = Workbooks.Open(Filename:=CheckReport).Worksheets("Sheet1")
            CheckLength = Checksheet.UsedRange.Rows.Count
            For Checkcell = 1 To CheckLength

                 Wordcheck = Checksheet.Cells(Checkcell, 1).Text

                    ' Set loop for each sheet in a workbook
                    For Each sheet In ActiveWorkbook.Worksheets

                         ' Set loop for each cell on a worksheet
                         Set CellCheck = sheet.Cells.Find(Wordcheck, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        If Not CellCheck Is Nothing Then
                            firstaddress = CellCheck.Address
                        End If

                            Do Until CellCheck Is Nothing

                                WS.Range("A5").Offset(a, 0).Value = Wordcheck
                                WS.Range("B5").Offset(a, 0).Value = Files
                                WS.Range("C5").Offset(a, 0).Value = sheet.Name
                                WS.Range("D5").Offset(a, 0).Value = CellCheck.Address
                                WS.Hyperlinks.Add Anchor:=WS.Range("E5").Offset(a, 0), Address:=Testfolder & Files, SubAddress:= _
                                sheet.Name & "!" & CellCheck.Address, TextToDisplay:="Link"

                                a = a + 1

                                Set CellCheck = Range("A1:A10").FindNext(after:=CellCheck)

                               If CellCheck.Address = firstaddress Then
                                 Exit Do
                               End If

                            Loop 

                  Next sheet

             Next Checkcell

            Workbooks(Files).Close SaveChanges:=False

            End If

        End If

    Files = Dir

    End If

Loop

End Sub

我修改了代码以根据活动表计数创建循环。现在它提供了多个重复的实例，而没有记录正确的cell.address。

Sub WordSearch()
Dim WS As Worksheet
Dim Testfolder As String
Dim a As Single
Dim sheet As Worksheet
Dim CheckReport As Variant
Dim CheckLength As Long
Dim Wordcheck As String
Dim Checksheet As Object
Dim CellLoop As Long

Set WS = Sheets.Add

' Open file folder for excel files
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Testfolder = .SelectedItems(1) & "\"
End With

'Open the target workbook
CheckReport = Application.GetOpenFilename("Excel-files,*.xls*", _
1, "Select Your CheckList File To Open", , False)

' Create Header and information for final sheet
WS.Range("A1") = "Path"
WS.Range("B1") = Testfolder
WS.Range("A2") = "CheckList:"
WS.Range("B2") = CheckReport
WS.Range("A4") = "Matched Word"
WS.Range("B4") = "Workbook"
WS.Range("C4") = "Worksheet"
WS.Range("D4") = "Cell Address"
WS.Range("E4") = "Link"

Cells.EntireColumn.AutoFit

Files = Dir(Testfolder)

'Set loop to search all files in the designated folder
Do Until Files = ""

    If Files = "." Or Files = ".." Then
    MsgBox "No Excel files found"

    Else
        If Right(Files, 3) = "xls" Or Right(Files, 4) = "xlsx" Or Right(Files, 4) = "xlsm" Then
            On Error Resume Next
            Workbooks.Open Filename:=Testfolder & Files, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
                WS.Range("B5").Offset(a, 0).Value = Files
                WS.Range("C5").Offset(a, 0).Value = "Password protected"
                a = a + 1

                On Error GoTo 0
            Else

            ' Open the CheckSheet to let loop count and get search words
            Set Checksheet = Workbooks.Open(Filename:=CheckReport).Worksheets("Sheet1")
            CheckLength = Checksheet.UsedRange.Rows.Count

            For Checkcell = 1 To CheckLength

                 Wordcheck = Checksheet.Cells(Checkcell, 1).Text

                    ' Set loop for each sheet in a workbook
                    For Each sheet In ActiveWorkbook.Worksheets
                    SheetCheck = ActiveSheet.UsedRange.Rows.Count

                    ' Set loop for each cell on a worksheet
                    For CellLoop = 1 To SheetCheck

                         Set CellCheck = sheet.Cells.Find(Wordcheck, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        If Not CellCheck Is Nothing Then
                            firstaddress = CellCheck.Address

                            Do

                                WS.Range("A5").Offset(a, 0).Value = Wordcheck
                                WS.Range("B5").Offset(a, 0).Value = Files
                                WS.Range("C5").Offset(a, 0).Value = sheet.Name
                                WS.Range("D5").Offset(a, 0).Value = CellCheck.Address
                                WS.Hyperlinks.Add Anchor:=WS.Range("E5").Offset(a, 0), Address:=Testfolder & Files, SubAddress:= _
                                sheet.Name & "!" & CellCheck.Address, TextToDisplay:="Link"

                                a = a + 1

                            Loop While Not CellCheck Is Nothing And CellCheck.Address <> firstaddress

                        End If

                        Next CellLoop

                    Next sheet

            Next Checkcell

            Workbooks(Files).Close SaveChanges:=False

            End If

        End If

    Files = Dir

    End If

Loop

End Sub

经过多次试验和错误...这是完成的VBA宏，用于获取文件夹位置和搜索字标准的用户输入，并生成另一个电子表格。

Sub WordSearch()
Dim WS As Worksheet
Dim Testfolder As String
Dim a As Single
Dim sheet As Worksheet
Dim CheckReport As Variant
Dim CheckLength As Long
Dim Wordcheck As String
Dim Checksheet As Object
Dim CellAddress As String

Set WS = Sheets.Add

MsgBox "Please select the Folder where the Excel files are located after you click OK."

' Open file folder for excel files
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the Excel Folder Location"
    .Show
    Testfolder = .SelectedItems(1) & "\"
End With

MsgBox "Please select the File that contains the Dirty Word list after. Click OK to continue."

'Open the target workbook
CheckReport = Application.GetOpenFilename("Excel-files,*.xls*", _
1, "Select Your Dirty Word List File To Open", , False)

' Create Header and information for final sheet
WS.Range("A1") = "Path"
WS.Range("B1") = Testfolder
WS.Range("A2") = "CheckList:"
WS.Range("B2") = CheckReport
WS.Range("A4") = "Matched Word"
WS.Range("B4") = "Workbook"
WS.Range("C4") = "Worksheet"
WS.Range("D4") = "Cell Address"
WS.Range("E4") = "Link"

Cells.EntireColumn.AutoFit

Files = Dir(Testfolder)

'Set loop to search all files in the designated folder
Do Until Files = ""

    If Files = "." Or Files = ".." Then
    MsgBox "No Excel files found"

    Else
        If Right(Files, 3) = "xls" Or Right(Files, 4) = "xlsx" Or Right(Files, 4) = "xlsm" Then
            On Error Resume Next
            Workbooks.Open Filename:=Testfolder & Files, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
                WS.Range("B5").Offset(a, 0).Value = Files
                WS.Range("C5").Offset(a, 0).Value = "Password protected"
                a = a + 1

                On Error GoTo 0
            Else

            ' Open the CheckSheet to let loop count and get search words
            Set Checksheet = Workbooks.Open(Filename:=CheckReport).Worksheets("Sheet1")
            CheckLength = Checksheet.UsedRange.Rows.Count

            For Checkcell = 1 To CheckLength

                 Wordcheck = Checksheet.Cells(Checkcell, 1).Text

                    ' Activate Current Workbook
                      Workbooks(Files).Activate
                    ' Set loop for each sheet in a workbook
                    For Each sheet In ActiveWorkbook.Worksheets

                    SheetCheck = sheet.UsedRange.Rows.Count

                         Set CellCheck = sheet.Cells.Find(What:=Wordcheck, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        If Not CellCheck Is Nothing Then
                            CellAddress = CellCheck.Address

                            Do

                                WS.Range("A5").Offset(a, 0).Value = Wordcheck
                                WS.Range("B5").Offset(a, 0).Value = Files
                                WS.Range("C5").Offset(a, 0).Value = sheet.Name
                                WS.Range("D5").Offset(a, 0).Value = CellCheck.Address
                                WS.Hyperlinks.Add Anchor:=WS.Range("E5").Offset(a, 0), Address:=Testfolder & Files, SubAddress:= _
                                sheet.Name & "!" & CellAddress, TextToDisplay:="Link"

                                a = a + 1

                                Set CellCheck = sheet.Cells.FindNext(After:=CellCheck)

                        Loop While Not CellCheck Is Nothing And CellCheck.Address <> CellAddress

                      End If

                    Next sheet

            Next Checkcell

            Workbooks(Files).Close SaveChanges:=False

            End If

        End If

    Files = Dir

    End If

Loop

End Sub

Answer 1

我终于明白了。没有什么比好老F8走过每一步而谷歌给你的选择。