VBA Mass Find and Replace just wipes cells-CodePudding

Relatively simple problem. I have a huge spreadsheet full of product codes. I need to change about 200 of them. I have the below code. I am just testing this at the moment before using it on the live system. When I run the Macro it just deletes all the data in the cells on the other sheet rather than replacing it with the new product code in the second column. All help greatly appreciated.

Sub Multi_FindReplace()

Dim sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant

  Set tbl = Worksheets("Sheet4").ListObjects("Table1")

  Set TempArray = tbl.DataBodyRange
  myArray = Application.Transpose(TempArray)
  
  fndList = 1
  rplcList = 2

  For x = LBound(myArray, 1) To UBound(myArray, 2)
      For Each sht In ActiveWorkbook.Worksheets
        If sht.Name <> tbl.Parent.Name Then
          
          sht.Cells.Replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
            SearchFormat:=False, ReplaceFormat:=False
        
        End If
      Next sht
  Next x

End Sub

CodePudding user response：

Try this:

Sub Multi_FindReplace()

    Dim sht As Worksheet, wb As Workbook, x As Long
    Dim fnd As String, rplc As String, tbl As ListObject, data As Variant

    Set wb = ActiveWorkbook
    Set tbl = wb.Worksheets("Sheet4").ListObjects("Table1")
    data = tbl.DataBodyRange.Value 'no need to transpose
    
    For x = LBound(data, 1) To UBound(data, 1) 'loop over data rows
        fnd = data(x, 1)                       'find value
        rplc = data(x, 2)                      'replace value
        If Len(fnd) > 0 And Len(rplc) > 0 Then 'make sure there are a pair of values
            For Each sht In wb.Worksheets
                If sht.Name <> tbl.Parent.Name Then
                  
                  sht.Cells.Replace What:=fnd, Replacement:=rplc, _
                      LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                      SearchFormat:=False, ReplaceFormat:=False
                
                End If
            Next sht
        End If           'have a pair of values
    Next x

End Sub