if values present in workbook insert in msgbox in which columns they are present-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")

you can enter in which columns the values are found in this

anser = MsgBox("found " & ResultRange.Count & "" & Chr(13) & _ "<" & xFind & ">" & Chr(13) & _ "code / word" & Chr(13) & _ "replace with" & Chr(13) & _ "<" & RepWith & ">?", vbInformation vbYesNo, "NOTICE!")

is it possible in the msgbox to insert in which columns of the workbook the values are found?

Option Explicit


Sub cell_all()

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


anser = MsgBox("found " & ResultRange.Count & "" & Chr(13) & _
         "<" & xFind & ">" & Chr(13) & _
         "code / word" & Chr(13) & _
         "replace with" & Chr(13) & _
         "<" & 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

CodePudding user response：

The idea is to loop through each cell in ResultRange.Cells, get the column letter from the address and assign it as key to a dictionary, this will remove any duplicate column letter along the way.

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

We then assign the dictionary's Keys to an array:

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

We then sort the array using QuickSort sub taken from wellsr.com:

Quicksort colArr, LBound(colArr), UBound(colArr)

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

Lastly modify your existing MsgBox to show the output.

Full code below:

Sub cell_all()

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