Modify Code to Run across multiple worksheets in directory

[tdm]

I have macro that deletes text string when found in worksheet. I need to modify code to be able to run across hundreds of worksheets in one directory/folder. Thanks in advance for help. Below is code that is working for worksheet.

Sub FindDelete()
Const words_to_find As String = "Internet release date"

Dim wS As Worksheet
Dim find_group() As String
Dim find As Variant
Dim found As Range

' Take the 'words_to_find' and split them at the ',' character into an array:
find_group = Split(words_to_find, "Internet, release, date")

For Each find In find_group
    If find <> "" Then
        On Error Resume Next
        For Each wS In Worksheets
            Do
                Set found = wS.UsedRange.Cells.find(What:=find, LookAt:=xlPart, SearchOrder _
                     :=xlByRows, MatchCase:=False, SearchFormat:=False)
                found.EntireRow.Delete
            Loop Until found Is Nothing
        Next
    End If
Next
End Sub

Moderator's Note: As per Forum Rule #3, please use code tags…Thanks.

[patel45]

A worksheet is a single page or sheet in a spreadsheet program such as Excel.
A workbook is a spreadsheet file. By default, each workbook in Excel contains three pages or worksheets.

[tigeravatar]

tdm,

Here's one way...

Sub FindDelete()
    
    Dim ws As Worksheet
    Dim rngFound As Range
    Dim rngDelete As Range
    Dim oShell As Object
    Dim arrFind As Variant
    Dim varFind As Variant
    Dim strFolderPath As String
    Dim strCurrentFile As String
    Dim strFirst As String
    
    'Adjust the search terms here as shown, they are not case sensitive
    arrFind = Array("internet", "release", "date")
    
    Set oShell = CreateObject("Shell.Application").BrowseForFolder(0, "Select Folder", 0)
    On Error Resume Next
    strFolderPath = oShell.Self.Path
    Set oShell = Nothing
    On Error GoTo 0
    If Len(strFolderPath) = 0 Then Exit Sub 'Pressed cancel
    
    strFolderPath = strFolderPath & Application.PathSeparator
    strCurrentFile = Dir(strFolderPath & "*.xls*")
    
    Application.ScreenUpdating = False
    Do
        With Workbooks.Open(strFolderPath & strCurrentFile)
            For Each varFind In arrFind
                For Each ws In .Sheets
                    Set rngFound = ws.UsedRange.find("*" & varFind & "*", ws.UsedRange.Cells(ws.UsedRange.Cells.Count), xlValues, xlWhole)
                    If Not rngFound Is Nothing Then
                        strFirst = rngFound.Address
                        Set rngDelete = rngFound
                        Do
                            Set rngDelete = Union(rngFound, rngDelete)
                            Set rngFound = ws.UsedRange.find("*" & varFind & "*", rngFound, xlValues, xlWhole)
                        Loop While rngFound.Address <> strFirst
                        rngDelete.EntireRow.Delete
                        Set rngFound = Nothing
                        Set rngDelete = Nothing
                        strFirst = vbNullString
                    End If
                Next
            Next
            .Close True
        End With
    Loop While Len(strCurrentFile) > 0
    Application.ScreenUpdating = True
    
    Set ws = Nothing
    Erase arrFind
    
End Sub