Looking to loop through multiple sheets and remove courses listed in columns H:T. These courses are listed in a table on sheet 2. I keep getting a script out of range error.

Sub RemoveWordsFromMultipleSheets()

    Dim ws As Worksheet
    Dim removalWords As Range
    Dim cell As Range
    Dim removalWord As Range
    Dim word As String
    Dim targetRange As Range
    Dim sheetNames As Variant
    Dim i As Long
    
    ' Define the workbook and the list of sheet names
    Dim wb As Workbook
    Set wb = Workbooks("Updated Masterv2") ' Your workbook name
    
    sheetNames = Array("SXF", "SFN", "FAR", "FGN", "BIS", "BEM", "Other", "LRH") ' List of sheets to process
    
    ' Set the range containing removal words from the "deactivated" table (assuming column 1 in the table)
    Set removalWords = wb.Sheets("Sheet2").ListObjects("deactivated").ListColumns(1).DataBodyRange ' Assuming table is on "Sheet2", adjust as necessary
    
    ' Loop through each sheet
    For i = LBound(sheetNames) To UBound(sheetNames)
        Set ws = wb.Sheets(sheetNames(i))
        
        ' Set the target range where words need to be replaced (you can adjust this to a specific range if needed)
        Set targetRange = ws.UsedRange ' Use the used range of the sheet, you can specify another range if needed
        
        ' Loop through each cell in the target range
        For Each cell In targetRange
            If Not IsEmpty(cell.Value) Then
                ' Loop through each removal word in the "deactivated" table
                For Each removalWord In removalWords
                    word = removalWord.Value
                    ' Replace the word in the cell with a blank (removal)
                    cell.Value = Replace(cell.Value, word, "")
                Next removalWord
            End If
        Next cell
    Next i

    MsgBox "Words have been removed from all specified sheets."

End Sub

Looking to loop through multiple sheets and remove courses listed in columns H:T. These courses are listed in a table on sheet 2. I keep getting a script out of range error.

Sub RemoveWordsFromMultipleSheets()

    Dim ws As Worksheet
    Dim removalWords As Range
    Dim cell As Range
    Dim removalWord As Range
    Dim word As String
    Dim targetRange As Range
    Dim sheetNames As Variant
    Dim i As Long
    
    ' Define the workbook and the list of sheet names
    Dim wb As Workbook
    Set wb = Workbooks("Updated Masterv2") ' Your workbook name
    
    sheetNames = Array("SXF", "SFN", "FAR", "FGN", "BIS", "BEM", "Other", "LRH") ' List of sheets to process
    
    ' Set the range containing removal words from the "deactivated" table (assuming column 1 in the table)
    Set removalWords = wb.Sheets("Sheet2").ListObjects("deactivated").ListColumns(1).DataBodyRange ' Assuming table is on "Sheet2", adjust as necessary
    
    ' Loop through each sheet
    For i = LBound(sheetNames) To UBound(sheetNames)
        Set ws = wb.Sheets(sheetNames(i))
        
        ' Set the target range where words need to be replaced (you can adjust this to a specific range if needed)
        Set targetRange = ws.UsedRange ' Use the used range of the sheet, you can specify another range if needed
        
        ' Loop through each cell in the target range
        For Each cell In targetRange
            If Not IsEmpty(cell.Value) Then
                ' Loop through each removal word in the "deactivated" table
                For Each removalWord In removalWords
                    word = removalWord.Value
                    ' Replace the word in the cell with a blank (removal)
                    cell.Value = Replace(cell.Value, word, "")
                Next removalWord
            End If
        Next cell
    Next i

    MsgBox "Words have been removed from all specified sheets."

End Sub

• excel
• vba

• 3 You get an out of range error where? – Tim Roberts Commented Mar 20 at 17:53
• 2 Workbooks("Updated Masterv2") it's safer to include the extension in the file name... – Tim Williams Commented Mar 20 at 17:57
• 2 Side note: Range.Replace should be called on the entire targetRange (efficient), not Replace cell-by-cell (inefficient). – BigBen Commented Mar 20 at 18:00
• 1 Also Set targetRange = Application.Intersect(ws.UsedRange, ws.Range("H:T")) if you only want to replace in columns H through T. – Tim Williams Commented Mar 20 at 18:30
• 1 Or just call ws.Range("H:T").Replace(...) and skip the Intersect. – BigBen Commented Mar 20 at 18:32

1 Answer 1

Replace/Remove Strings in Columns of Specific Sheets

Sub RemoveWordsFromMultipleSheets()
    
    ' Define constants.
    Const WORKBOOK_NAME As String = "Updated Masterv2.xlsx" ' adjust!!!
    Const REMOVAL_SHEET_NAME As String = "Sheet2"
    Const REMOVAL_TABLE_NAME As String = "Deactivated"
    Const REMOVAL_TABLE_COLUMN_INDEX As Long = 1
    Dim PROCESS_SHEET_NAMES() As Variant: PROCESS_SHEET_NAMES = Array( _
        "SXF", "SFN", "FAR", "FGN", "BIS", "BEM", "Other", "LRH")
    Const PROCESS_COLUMNS As String = "H:T"
    Const PROCESS_FIRST_ROW As Long = 2 ' adjust!!!
    Const PROCESS_REPLACEMENT As String = ""
    
    ' Reference the workbook.
    Dim wb As Workbook:
    On Error Resume Next
        Set wb = Workbooks(WORKBOOK_NAME)
    On Error GoTo 0
    If wb Is Nothing Then
        MsgBox "The workbook """ & WORKBOOK_NAME & """ is not open!", _
            vbExclamation
        Exit Sub
    End If
    
    ' Reference the removal sheet, table and range.
    Dim rws As Worksheet:
    On Error Resume Next
        Set rws = wb.Sheets(REMOVAL_SHEET_NAME)
    On Error GoTo 0
    If rws Is Nothing Then
        MsgBox "The sheet """ & REMOVAL_SHEET_NAME _
            & """ doesn't exist in workbook """ & wb.Name & """!", _
            vbExclamation
        Exit Sub
    End If
    Dim rlo As ListObject:
    On Error Resume Next
        Set rlo = rws.ListObjects(REMOVAL_TABLE_NAME)
    On Error GoTo 0
    If rlo Is Nothing Then
        MsgBox "The table """ & REMOVAL_TABLE_NAME _
            & """ doesn't exist in sheet """ & rws.Name & """!", _
            vbExclamation
        Exit Sub
    End If
    Dim rRowsCount As Long: rRowsCount = rlo.ListRows.Count
    If rRowsCount = 0 Then
        MsgBox "The table """ & REMOVAL_TABLE_NAME & """ is empty!", _
            vbExclamation
        Exit Sub
    End If
    If rlo.ListColumns.Count < REMOVAL_TABLE_COLUMN_INDEX Then
        MsgBox "The table """ & REMOVAL_TABLE_NAME _
            & """ has only " & rlo.ListColumns.Count & " columns!", vbExclamation
        Exit Sub
    End If
    Dim rrg As Range:
    Set rrg = rlo.ListColumns(REMOVAL_TABLE_COLUMN_INDEX).DataBodyRange
    
    ' Return the values from the removal range in an array.
    Dim rData() As Variant:
    If rRowsCount = 1 Then
        ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rrg.Value
    Else
        rData = rrg.Value
    End If
    
    ' Declare additional variables.
    Dim pws As Worksheet, prg As Range, plcell As Range, pSheetName As Variant
    Dim rRow As Long
    
    ' Loop through the names of the sheets to be processed...
    For Each pSheetName In PROCESS_SHEET_NAMES
        ' Reference the processing sheet.
        Set pws = Nothing
        On Error Resume Next
            Set pws = wb.Sheets(pSheetName)
        On Error GoTo 0
        If Not pws Is Nothing Then
            ' Reference the processing range.
            Set prg = Nothing
            With pws.Rows(PROCESS_FIRST_ROW).Columns(PROCESS_COLUMNS)
                With .Resize(pws.Rows.Count - .Row + 1)
                    Set plcell = .Find("*", , xlFormulas, , _
                        xlByRows, xlPrevious)
                End With
                If Not plcell Is Nothing Then
                    Set prg = .Resize(plcell.Row - .Row + 1)
                End If
            End With
            ' Replace (remove).
            If Not prg Is Nothing Then
                ' Loop through the strings to be replaced (removed).
                For rRow = 1 To rRowsCount
                    prg.Replace rData(rRow, 1), PROCESS_REPLACEMENT, _
                        xlPart, , False
                Next rRow
            'Else ' no data in sheet
            End If
        'Else ' sheet not found
        End If
    Next pSheetName
    
    ' Inform.
    MsgBox "Words have been removed from all specified sheets.", vbInformation

End Sub