Macro to Find Two Columns

[miva0601]

I receive a file each month where I need to do a find and replace on two columns.
I highlight both columns and find and replace
find "_GUAR" replace all with nothing
find"," replace all with a space
find "HEALTHMART" replace all with HM
find "HEALTH MART" replace all with HM

Here's what the data looks like when I receive it (before I do the above operations)

Preliminary 202109 TPR.xlsm
	BG	BH
1	Waivers	Missed Criteria
78	GPR_GUAR,HEALTHMART	GPR
125	GPR_GUAR,BPR_GUAR,BPR_GUAR	#
136	GPR_GUAR,BPR_GUAR,HEALTHMART	BPR
137	GPR_GUAR,BPR_GUAR,HEALTHMART	#
163	BPR_GUAR	BPR
164	GPR_GUAR,BPR_GUAR,HEALTHMART	BPR,GPR
177	HEALTHMART	HEALTHMART
254	GPR_GUAR	GPR
269	GPR_GUAR,BPR_GUAR,BPR_GUAR	BPR,GPR
272	BPR_GUAR	BPR
309	GPR_GUAR	GPR
332	BPR_GUAR	#
345	BPR_GUAR	#
390	BPR_GUAR	#
420	GPR_GUAR	GPR
440	HEALTHMART,GPR_GUAR	GPR
451	GPR_GUAR,HEALTHMART	GPR
467	HEALTHMART	HEALTHMART
490	GPR_GUAR,BPR_GUAR,BPR_GUAR	BPR,GPR,HEALTHMART
494	BPR_GUAR	BPR
576	GPR_GUAR,BPR_GUAR,BPR_GUAR	BPR,GPR
580	BPR_GUAR	BPR
New

After I do the above listed operations, the data looks like the below.

Preliminary 202109 TPR.xlsm
	BG	BH
1	Waivers	Missed Criteria
78	GPR HM	GPR
125	GPR BPR BPR	#
136	GPR BPR HM	BPR
137	GPR BPR HM	#
163	BPR	BPR
164	GPR BPR HM	BPR GPR
177	HM	HM
254	GPR	GPR
269	GPR BPR BPR	BPR GPR
272	BPR	BPR
309	GPR	GPR
332	BPR	#
345	BPR	#
390	BPR	#
420	GPR	GPR
New

At this point, I need to put each cell in alphabetical order and no repeats (not sort the entire column, but the cell, so basically row 269 has GPR BPR BPR and it needs to be BPR GPR), so that ultimately I can add a column with an IF formula that would look at each row and if the two columns match it would say "All Passed")
Here's what final data should look like

Preliminary 202109 TPR.xlsm
	BG	BH
1	Waivers	Missed Criteria
78	GPR HM	GPR
125	BPR GPR	#
136	BPR GPR HM	BPR
137	GPR BPR HM	#
163	BPR	BPR
164	BPR GPR HM	BPR GPR
177	HM	HM
254	GPR	GPR
269	BPR GPR	BPR GPR
272	BPR	BPR
309	GPR	GPR
332	BPR	#
345	BPR	#
390	BPR	#
420	GPR	GPR
440	GPR HM	GPR
451	GPR HM	GPR
467	HM	HM
New

A couple of notes:
The column headers will never change and it will always be column BG and BH
The number of rows does change each month
'#' no action for this, I later just delete this and the cell will be blank
Some months, the Missed Criteria will also have "GCR" which I'd like to put in alphabetical order, so it'd be great if the code allowed for this. Example Missed Criteria column has BPR GPR HM GCR should be BPR GCR GPR HM

Thank you in advance

 

[DanteAmor]

Put all of the following code in a module.
Run the macro "replace_on_two_columns"

Sub replace_on_two_columns()
  Dim a As Variant
  Dim i As Long
  Application.ScreenUpdating = False
  
  With Range("BG2:BH" & Range("BG" & Rows.Count).End(3).Row)
    .Replace "_GUAR", "", xlPart, , False
    .Replace ",", " ", xlPart, , False
    .Replace "HEALTHMART", "HM", xlPart, , False
    .Replace "HEALTH MART", "HM", xlPart, , False
    a = .Value
      ReDim b(1 To UBound(a, 1), 1 To 2)
      For i = 1 To UBound(a)
        b(i, 1) = finaldata(a(i, 1))
        b(i, 2) = finaldata(a(i, 2))
      Next
    .Value = b
  End With
End Sub

Function finaldata(data)
  Dim dic As Object, col As Object
  Dim ky As Variant, itm As Variant
  Dim tmp As String
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set col = CreateObject("System.Collections.ArrayList")

  For Each itm In Split(data, " ")
    dic(itm) = Empty
  Next
  For Each ky In dic.keys
    col.Add ky
  Next
  col.Sort
  For Each ky In col
    If tmp = "" Then tmp = ky Else tmp = tmp & " " & ky
  Next ky
  finaldata = tmp
End Function

 

[johnnyL]

@DanteAmor that code seems a bit slow for your standards

 

[johnnyL]

This should be way faster:

Sub SheetReplacements()                                               ' 66940 avg
'
    Dim LastRowInSheet  As Long
    Dim ReplaceArray    As Variant
    Dim WS              As Worksheet
'
    Set WS = Sheets("Sheet1")                                                       ' <--- Set this to the sheet name
'
    LastRowInSheet = WS.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row   ' Returns a Row Number
'
    With WS.Range("BG2:BH" & LastRowInSheet)
        .Replace What:="HEALTHMART", Replacement:="HM", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
        .Replace What:="HEALTH MART", Replacement:="HM", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
        .Replace What:="_GUAR", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
        .Replace What:=",", Replacement:=" ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    End With
'
    ReplaceArray = WS.Range("BG2:BH" & LastRowInSheet)                              ' 2 dimensional one based array
'
    For i = 1 To UBound(ReplaceArray)
        If ReplaceArray(i, 1) <> vbNullString Then
            ReplaceArray(i, 1) = RemoveDupeWords((ReplaceArray(i, 1)), " ")
            ReplaceArray(i, 1) = StrSort(ReplaceArray(i, 1))
            ReplaceArray(i, 2) = RemoveDupeWords((ReplaceArray(i, 2)), " ")
            ReplaceArray(i, 2) = StrSort(ReplaceArray(i, 2))
        End If
    Next
'
    WS.Range("BG2:BH" & LastRowInSheet) = ReplaceArray
End Sub


Function RemoveDupeWords(text As String, Optional Delimiter As String = " ") As String
    Dim dictionary As Object
    Dim x, part
 '
    Set dictionary = CreateObject("Scripting.Dictionary")
'
    dictionary.CompareMode = vbTextCompare
'
    For Each x In Split(text, Delimiter)
        part = Trim(x)
'
        If part <> "" And Not dictionary.Exists(part) Then
            dictionary.Add part, Nothing
        End If
    Next
 '
    If dictionary.Count > 0 Then
        RemoveDupeWords = Join(dictionary.keys, Delimiter)
    Else
        RemoveDupeWords = ""
    End If
 '
    Set dictionary = Nothing
End Function


Function StrSort(ByVal sInp As String, Optional bDescending As Boolean = False) As String
'
    Dim asSS() As String                ' substring array
    Dim sSS As String                   ' temp string for exchange
    Dim n As Long
    Dim i As Long
    Dim j As Long
'
'   sorts a space-delimited string
    asSS = Split(sInp, " ")
'
    n = UBound(asSS)
'
    For i = 0 To n
        asSS(i) = Trim(asSS(i))
    Next
'
    If n < 1 Then
        StrSort = sInp
    Else
        For i = 0 To n - 1
            For j = i + 1 To n
                If (asSS(j) < asSS(i)) Xor bDescending Then
                    sSS = asSS(i)
                    asSS(i) = asSS(j)
                    asSS(j) = sSS
                End If
            Next j
        Next i
'
        StrSort = Join(asSS, " ")
    End If
End Function

 

[DanteAmor]

Here a faster code.
With 10,000 records.
My code from post #2: 20 seconds
Code from post #4: 16 seconds.
My updated code: 4 seconds.

Sub replace_on_two_columns_2()
  Dim a As Variant
  Dim i As Long
  Application.ScreenUpdating = False
  With ActiveSheet.Range("BG2:BH" & ActiveSheet.Range("BG" & Rows.Count).End(3).Row)
    .Replace "_GUAR", "", xlPart, , False
    .Replace ",", " ", xlPart, , False
    .Replace "HEALTHMART", "HM", xlPart, , False
    .Replace "HEALTH MART", "HM", xlPart, , False
    a = .Value
      ReDim b(1 To UBound(a, 1), 1 To 2)
      For i = 1 To UBound(a)
        b(i, 1) = finaldata_2(a(i, 1))
        b(i, 2) = finaldata_2(a(i, 2))
      Next
    .Value = b
  End With
End Sub

Function finaldata_2(data)
  Dim a As Variant, itm As Variant
  Dim valores As New Collection
  Dim bex As Boolean
  Dim i As Long

  For Each itm In Split(data, " ")
    bex = False
    For i = 1 To valores.Count
      Select Case StrComp(valores(i), itm, vbTextCompare)
        Case 0
          bex = True
          Exit For
        Case 1
          bex = True
          valores.Add itm, itm, Before:=i
          Exit For
      End Select
    Next
    If bex = False Then valores.Add itm, itm
  Next
  ReDim a(1 To valores.Count)
  For i = 1 To valores.Count
    a(i) = valores(i)
  Next
  finaldata_2 = Join(a, " ")
End Function

 

[johnnyL]

Dang it @DanteAmor, now I have to find my stop watch again.

 

[johnnyL]

@DanteAmor, unfortunately I can't stress test your latest submission because it errors out Run time 9, Subscript out of range ... ReDim a(1 To valores.Count)

It appears to run once, but does not want to run multiple times for my my multiple average timing test.

I will try to take another look at it after I get some zzzz.

 

[DanteAmor]

it errors out Run time 9, Subscript out of range ... ReDim a(1 To valores.Count)

Here the fix when there are empty cells:

Sub replace_on_two_columns_2()
  Dim a As Variant
  Dim i As Long
  Application.ScreenUpdating = False
  With ActiveSheet.Range("BG2:BH" & ActiveSheet.Range("BG" & Rows.Count).End(3).Row)
    .Replace "_GUAR", "", xlPart, , False
    .Replace ",", " ", xlPart, , False
    .Replace "HEALTHMART", "HM", xlPart, , False
    .Replace "HEALTH MART", "HM", xlPart, , False
    a = .Value
      ReDim b(1 To UBound(a, 1), 1 To 2)
      For i = 1 To UBound(a)
        If a(i, 1) <> "" Then b(i, 1) = finaldata_2(a(i, 1))
        If a(i, 1) <> "" Then b(i, 2) = finaldata_2(a(i, 2))
      Next
    .Value = b
  End With
End Sub

Function finaldata_2(data)
  Dim a As Variant, itm As Variant
  Dim valores As New Collection
  Dim bex As Boolean
  Dim i As Long

  For Each itm In Split(data, " ")
    bex = False
    For i = 1 To valores.Count
      Select Case StrComp(valores(i), itm, vbTextCompare)
        Case 0
          bex = True
          Exit For
        Case 1
          bex = True
          valores.Add itm, itm, Before:=i
          Exit For
      End Select
    Next
    If bex = False Then valores.Add itm, itm
  Next
  ReDim a(1 To valores.Count)
  For i = 1 To valores.Count
    a(i) = valores(i)
  Next
  finaldata_2 = Join(a, " ")
End Function

 

[DanteAmor]

The most time is consumed by using the Replace function on the sheet. I use the replace function but in memory.
Now the execution is immediate:

Sub replace_on_two_columns_2()
  Dim a As Variant
  Dim i As Long
  Application.ScreenUpdating = False
  With ActiveSheet.Range("BG2:BH" & ActiveSheet.Range("BG" & Rows.Count).End(3).Row)
    a = .Value
      ReDim b(1 To UBound(a, 1), 1 To 2)
      For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
          b(i, 1) = finaldata_2(replacedata(a(i, 1)))
        End If
        If a(i, 2) <> "" Then
          b(i, 2) = finaldata_2(replacedata(a(i, 2)))
        End If
      Next
    .Value = b
  End With
End Sub

Function replacedata(data)
  data = Replace(Replace(data, "_GUAR", "", , , vbTextCompare), ",", " ")
  data = Replace(data, "HEALTHMART", "HM", , , vbTextCompare)
  replacedata = Replace(data, "HEALTH MART", "HM", , , vbTextCompare)
End Function

Function finaldata_2(data)
  Dim a As Variant, itm As Variant
  Dim valores As New Collection
  Dim bex As Boolean
  Dim i As Long

  For Each itm In Split(data, " ")
    bex = False
    For i = 1 To valores.Count
      Select Case StrComp(valores(i), itm, vbTextCompare)
        Case 0
          bex = True
          Exit For
        Case 1
          bex = True
          valores.Add itm, itm, Before:=i
          Exit For
      End Select
    Next
    If bex = False Then valores.Add itm, itm
  Next
  ReDim a(1 To valores.Count)
  For i = 1 To valores.Count
    a(i) = valores(i)
  Next
  finaldata_2 = Join(a, " ")
End Function

 

[johnnyL]

.55 average seconds with your last code posted for 10k rows. I think that is more than acceptable.