values found with macros are not replaced if inserted with copy / paste-CodePudding

the attached macro is used to find values with

xFind = Application.InputBox("code / word to search:", "search")

and replace them with

RepWith = Application.InputBox("Replace with :", "replace")

It does not work properly

if the values are entered with the computer keyboard they are replaced

if the values are pasted with copy / paste they are not replaced

Option Explicit

Sub cell_all_new_2() 'celle colonna

Dim FoundCell As Range
Dim FirstFound As Range
Dim xFind As Variant
Dim ResultRange As Range
Dim RepWith As Variant
Dim anser As Integer
Dim CellsToRep As Variant
Dim j As Long
Dim mAdrs As String

Dim Col As Variant
Dim avviso As String
       
xFind = Application.InputBox("code / word to search:", "search")
If xFind = False Then Exit Sub

RepWith = Application.InputBox("Replace with :", "replace")
If RepWith = False Then Exit Sub

Set FoundCell = Cells.Find(What:=xFind, _
        After:=ActiveCell, _
        LookIn:=xlFormulas, _
        LookAt:=xlPart, _
        SearchOrder:=xlByRows, _
        MatchCase:=False)
           
If Not FoundCell Is Nothing Then

    Set FirstFound = FoundCell
    Do Until False
        If ResultRange Is Nothing Then
            Set ResultRange = FoundCell
        Else
            Set ResultRange = Application.Union(ResultRange, FoundCell)
        End If
        
        Set FoundCell = Cells.FindNext(After:=FoundCell)
         
        If (FoundCell Is Nothing) Then
            Exit Do
        End If
        If (FoundCell.Address = FirstFound.Address) Then
            Exit Do
        End If
    Loop
End If

If ResultRange Is Nothing Then
    anser = MsgBox("no occurrence found! ", vbCritical   vbDefaultButton2, "notice!")
    Exit Sub
End If

Dim loopCell As Range
Dim colDict As Object
Set colDict = CreateObject("Scripting.Dictionary")

'Loop through each cell and assign the column letter from its address to the dictionary (to remove duplicate)
For Each loopCell In ResultRange.Cells
    colDict(Split(loopCell.Address, "$")(1)) = 1
Next loopCell

'Assign an array from the dictionary keys
Dim colArr As Variant
colArr = colDict.Keys
Set colDict = Nothing

'Sort the array alphabetically
Quicksort colArr, LBound(colArr), UBound(colArr)

anser = MsgBox("found " & ResultRange.Count & "" & vbCr & _
         "<" & xFind & ">" & vbCr & _
         "in column <" & Join(colArr, " / ") & ">" & vbCr & _
         "code / word" & vbCr & _
         "replace with" & vbCr & _
         "<" & RepWith & ">?", vbInformation   vbYesNo, "NOTICE!")

If anser = vbNo Then Exit Sub

mAdrs = ResultRange.Address
mAdrs = Replace(mAdrs, ":", ",")
CellsToRep = Split(mAdrs, ",")

For j = 0 To UBound(CellsToRep)
    Range(CellsToRep(j)) = Replace(Range(CellsToRep(j)), xFind, RepWith)
Next

End Sub

Sub Quicksort(vArray As Variant, arrLbound As Long, arrUbound As Long)
    'Sorts a one-dimensional VBA array from smallest to largest
    'using a very fast quicksort algorithm variant.
    Dim pivotVal As Variant
    Dim vSwap    As Variant
    Dim tmpLow   As Long
    Dim tmpHi    As Long
     
    tmpLow = arrLbound
    tmpHi = arrUbound
    pivotVal = vArray((arrLbound   arrUbound) \ 2)
     
    While (tmpLow <= tmpHi) 'divide
       While (vArray(tmpLow) < pivotVal And tmpLow < arrUbound)
          tmpLow = tmpLow   1
       Wend
      
       While (pivotVal < vArray(tmpHi) And tmpHi > arrLbound)
          tmpHi = tmpHi - 1
       Wend
     
       If (tmpLow <= tmpHi) Then
          vSwap = vArray(tmpLow)
          vArray(tmpLow) = vArray(tmpHi)
          vArray(tmpHi) = vSwap
          tmpLow = tmpLow   1
          tmpHi = tmpHi - 1
       End If
    Wend
     
    If (arrLbound < tmpHi) Then Quicksort vArray, arrLbound, tmpHi 'conquer
    If (tmpLow < arrUbound) Then Quicksort vArray, tmpLow, arrUbound 'conquer
End Sub

CodePudding user response：

Your logic to get the cells in ResultRange is flawed once there is a continuous range e.g. A range of A1:A10 means there are 10 cells but mAdrs = Replace(mAdrs, ":", ",") will make A1:A10 into A1,A10 which is totally different (2 cells).

Replace this block of codes:

mAdrs = ResultRange.Address
mAdrs = Replace(mAdrs, ":", ",")
CellsToRep = Split(mAdrs, ",")

For j = 0 To UBound(CellsToRep)
    Range(CellsToRep(j)) = Replace(Range(CellsToRep(j)), xFind, RepWith)
Next

To:

For Each loopCell In ResultRange.Cells
    loopCell.Value = Replace(loopCell.Value, xFind, RepWith)
Next loopCell