Find and replace in several (not all) sheets

Hi there,

Take a look at the attached workbook and see if it does what you need.

Click on the "List All Worksheets" button - this will create a table containing the names of all of the worksheets in the workbook. Then delete from this list the names of those worksheets on which you do NOT want Find And Replace operations performed.

Then click on the "Find And Replace" button.


The replacement value tables are divided into two types: Letter Case correction (for which only the final value need be specified) and Word correction (for which the initial and final values need be specified).


The workbook uses the following code:

Option Explicit


'=========================================================================================
'=========================================================================================


Const msSHEET_NAME__SUBSTITUTIONS   As String = "List of Substitutions"
Const msSHEET_NAMES                 As String = "tblSheetNames"


'=========================================================================================
'=========================================================================================


Private Sub ListAllWorksheets()

    Const sFIRST_CELL       As String = "ptrSheetNames_First"

    Dim iNoOfSheets         As Integer
    Dim rSheetNames         As Range
    Dim rFirstCell          As Range
    Dim sRefersTo           As String
    Dim iSheetNo            As Integer
    Dim wks                 As Worksheet

    Set wks = ThisWorkbook.Worksheets(msSHEET_NAME__SUBSTITUTIONS)

    iNoOfSheets = ThisWorkbook.Worksheets.Count

'   Create a range which can hold the Names of each of the worksheets in this workbook
    Set rFirstCell = wks.Range(sFIRST_CELL)
    With rFirstCell
        Set rSheetNames = Range(.Cells(1, 1), _
                                .Cells(iNoOfSheets, 1))
    End With

'   Create a worksheet-level defined Name which references the above Range
    sRefersTo = "='" & msSHEET_NAME__SUBSTITUTIONS & "'!" & rSheetNames.Address
    wks.Names.Add Name:=msSHEET_NAMES, RefersTo:=sRefersTo

'   Store the Names of each of the worksheets in the named range defined above
    For iSheetNo = 1 To iNoOfSheets
        rSheetNames.Cells(iSheetNo, 1).Value = ThisWorkbook.Worksheets(iSheetNo).Name
    Next iSheetNo

End Sub


'=========================================================================================
'=========================================================================================


Private Sub FindAndReplace()

    Const sCORRECTIONS__CASE    As String = "tblCaseCorrections"
    Const sCORRECTIONS__WORD    As String = "tblWordCorrections"

    Dim vaWorksheetNames        As Variant
    Dim wksSubstitutions        As Worksheet
    Dim rCaseCorrections        As Range
    Dim rWordCorrections        As Range
    Dim sValue_Replace          As String
    Dim sValue_Find             As String
    Dim sSheetName              As String
    Dim iSheetNo                As Integer
    Dim rCell                   As Range
    Dim wks                     As Worksheet

    Set wksSubstitutions = ThisWorkbook.Worksheets(msSHEET_NAME__SUBSTITUTIONS)

    Set rCaseCorrections = wksSubstitutions.Range(sCORRECTIONS__CASE)
    Set rWordCorrections = wksSubstitutions.Range(sCORRECTIONS__WORD)

    vaWorksheetNames = mvaWorksheetNames()

    For iSheetNo = LBound(vaWorksheetNames) To UBound(vaWorksheetNames)

        sSheetName = vaWorksheetNames(iSheetNo)

        Set wks = ThisWorkbook.Worksheets(sSheetName)

'       Perform Letter Case corrections
        For Each rCell In rCaseCorrections.Cells

            sValue_Find = rCell.Value

            If sValue_Find <> vbNullString Then

                sValue_Replace = rCell.Value

                wks.UsedRange.Cells.Replace What:=sValue_Find, _
                                            Replacement:=sValue_Replace, _
                                            LookAt:=xlWhole, MatchCase:=False

            End If

        Next rCell

'       Perform Word Case corrections
        For Each rCell In rWordCorrections.Columns(1).Cells

            sValue_Find = rCell.Value

            If sValue_Find <> vbNullString Then

                sValue_Replace = rCell.Offset(0, 1).Value

                wks.UsedRange.Cells.Replace What:=sValue_Find, _
                                            Replacement:=sValue_Replace, _
                                            LookAt:=xlWhole, MatchCase:=False

            End If

        Next rCell

    Next iSheetNo

End Sub


'=========================================================================================
'=========================================================================================


Private Function mvaWorksheetNames() As Variant

'   This function returns an array containing the names of all of the worksheets
'   on which Find And Replace operations are to be performed

    Dim vaSheetNames    As Variant
    Dim rSheetNames     As Range
    Dim rCell           As Range
    Dim wks             As Worksheet

    Set wks = ThisWorkbook.Worksheets(msSHEET_NAME__SUBSTITUTIONS)

    Set rSheetNames = wks.Range(wks.Names(msSHEET_NAMES))

    ReDim vaSheetNames(0)

    For Each rCell In rSheetNames.Cells

        If rCell.Value <> vbNullString Then

            If UBound(vaSheetNames) > 0 Then

                  ReDim Preserve vaSheetNames(1 To UBound(vaSheetNames) + 1)
                  vaSheetNames(UBound(vaSheetNames)) = rCell.Value

            Else: ReDim vaSheetNames(1 To 1)
                  vaSheetNames(1) = rCell.Value

            End If

        End If

    Next rCell

    mvaWorksheetNames = vaSheetNames

End Function

The highlighted value may be changed to suit your requirements.


Hope this helps - please let me know how you get on.

Regards,

Greg M