Блог

прикрепленный макрос используется для поиска значений с

xFind = Приложение.Поле ввода(«код / слово для поиска:», «поиск»)

и замените их на

RepWith = Заявка.Поле ввода(«Заменить на :», «заменить»)

Это не работает должным образом

если значения вводятся с клавиатуры компьютера, они заменяются

если значения вставлены с помощью копирования / вставки, они не заменяются

 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 " amp; ResultRange.Count amp; "" amp; vbCr amp; _
         "<" amp; xFind amp; ">" amp; vbCr amp; _
         "in column <" amp; Join(colArr, " / ") amp; ">" amp; vbCr amp; _
         "code / word" amp; vbCr amp; _
         "replace with" amp; vbCr amp; _
         "<" amp; RepWith amp; ">?", 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
 

Ваша логика для ввода ячеек ResultRange ошибочна, если есть непрерывный диапазон, например, диапазон A1:A10 означает, что есть 10 ячеек, но mAdrs = Replace(mAdrs, ":", ",") A1:A10 A1,A10 они будут совершенно разными (2 ячейки).

Замените этот блок кодов:

 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
 

Для:

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