Captilize Select Characters Within A Cell

[zoom38]

Hello, I have the following sub that compares the contents of a cell to an acronym list. When it finds an acronym that is on the list I need it to capitalize the acronym within the cell. Anyone know how to modify the sub so that it will capitalize only the acronyms that are found within the cell? I can change the character font but can't figure out how to capitalize only those characters. I tried Ucase but that capitalizes all of the text within the cell.

Sub CapitalizeAcronyms(rng As Range)
Dim AcronymToFind As String
Dim iSeek As Long
  
ActiveSheet.Unprotect
Set rngsource = Range(ActiveCell.Address)
  
LastRow = Sheets("Acronyms").UsedRange.Rows.count

On Error Resume Next
With rng
   For x = 2 To LastRow
      AcronymToFind = Sheets("Acronyms").Range("A" & x).Value
      If AcronymToFind = "" Then GoTo b
      iSeek = InStr(1, rng.Value, AcronymToFind, vbTextCompare)
      Do While iSeek > 0
         With rng.Characters(iSeek, Len(AcronymToFind)).Font
            '.Name = "Arial"
            '.Size = 14
            .Bold = True
            '.Color = RGB(200, 200, 200)
            '.ColorIndex = 15
         End With
         GoTo b
    Loop
b:
   Next x
End With
ActiveSheet.Protect
End Sub

[GTO]

Lightly tested, but does this do the trick?

Option Explicit
'With data below on Sheet1...
'      A   B
'1    ECT Cobbler
'2    COB lectured
'3    LAD ladder
'4    CAD cashier
'5    CAS tack
'6    TAC caddy
'7    API sextant
'8    SEX mapi
Sub example()
Dim CellAcronym As Range, CellWord As Range
Dim lPosition As Long, lLen As Long
Dim sLeft As String, sMid As String, sRight As String
  For Each CellWord In Sheet1.Range("B1:B8").Cells
    For Each CellAcronym In Sheet1.Range("A1:A8").Cells
      lPosition = InStr(1, CellWord.Value, CellAcronym, vbTextCompare)
      lLen = Len(CellAcronym.Value)
      
      If lPosition > 0 Then
        If lPosition = 1 Then
          sLeft = UCase$(CellAcronym.Value)
          sMid = Mid$(CellWord.Value, lLen + 1)
          sRight = vbNullString
        ElseIf lPosition + lLen - 1 = Len(CellWord.Value) Then
          sLeft = Left$(CellWord.Value, lPosition - 1)
          sMid = UCase$(CellAcronym.Value)
          sRight = vbNullString
        Else
          sLeft = Left$(CellWord.Value, lPosition - 1)
          sMid = UCase$(CellAcronym.Value)
          sRight = Mid$(CellWord.Value, lPosition + lLen)
        End If
      
        CellWord.Value = sLeft & sMid & sRight
        Exit For
      End If
      
    Next
  Next
End Sub

Hope that helps,

Mark

[Paul_Hossler]

I wasn't sure how you intended to use it, so I added a drive sub to test the algorithm

Option Explicit
Sub drv()
    Call CapitalizeAcronyms(ActiveSheet.Cells(1, 1), Worksheets("Acronyms").Cells(1, 1).CurrentRegion)
End Sub


Sub CapitalizeAcronyms(c As Range, rngAcronyms As Range)
    Dim AcronymToFind As String
    Dim iSeek As Long, i As Long
     
     
    With c
        For i = 2 To rngAcronyms.Rows.Count
            AcronymToFind = rngAcronyms.Cells(i, 1).Value
            
            iSeek = InStr(1, .Value, AcronymToFind, vbTextCompare)
            
            Do While iSeek > 0
                .Value = Left(.Value, iSeek - 1) & UCase(Mid(.Value, iSeek, Len(AcronymToFind))) & Right(.Value, Len(.Value) - iSeek - Len(AcronymToFind) + 1)
                
                With .Characters(iSeek, Len(AcronymToFind)).Font
                     '.Name = "Arial"
                     '.Size = 14
                    .Bold = True
                     '.Color = RGB(200, 200, 200)
                     '.ColorIndex = 15
                End With
                
                iSeek = InStr(iSeek + Len(AcronymToFind), .Value, AcronymToFind, vbTextCompare)
            
            Loop
        Next I
    End With

End Sub

[zoom38]

Thanks for the replies. My apologies for not being clear. I have a sheet ("Summary") that I will be entering a paragraph into one cell (B7, B9, B11 and/or B13). From the Worksheet_Change event I have a SentenceCase sub that corrects the paragraph to sentence case. Then then CapitalizeAcronyms Sub is activated to capitalize only the acronyms that are found.

  If Not Intersect(Target, Range("B7,B9,B11,B13")) Is Nothing Then
        CapitalizeAcronyms Target
        'Call drv
        GoTo a
    End If

The CapitalizeAcronyms sub loops through Acronyms listed on the ("Acronyms") sheet in column a. If it finds an acronym that is in the cell paragraph, I need it to capitalize it within the cell on the ("Summary") sheet.

Paul, i ran into an issue with Worksheets("Acronyms").Cells(1, 1).CurrentRegion) because my acronyms are not in every row. I tried .usedrange but it failed. However after modifying it as below I it runs nicely with one exception. It runs forever because of the SentenceCase sub in the Worksheet_Change event on the ("Summary") sheet.

Sub CapitalizeAcronyms(c As Range)
    Dim AcronymToFind As String
    Dim iSeek As Long, i As Long
    Dim LastRow As Long
   

    LastRow = Sheets("Acronyms").UsedRange.Rows.Count
    With c
        For i = 2 To LastRow
            'AcronymToFind = rngAcronyms.Cells(i, 1).Value
            AcronymToFind = Sheets("Acronyms").Range("A" & i).Value
            If AcronymToFind = "" Then GoTo b
            iSeek = InStr(1, .Value, AcronymToFind, vbTextCompare)
             
            Do While iSeek > 0
                .Value = Left(.Value, iSeek - 1) & UCase(Mid(.Value, iSeek, Len(AcronymToFind))) & Right(.Value, Len(.Value) - iSeek - Len(AcronymToFind) + 1)
                iSeek = InStr(iSeek + Len(AcronymToFind), .Value, AcronymToFind, vbTextCompare)
            GoTo b
            Loop
b:
        Next i
    End With
     
End Sub

Is there a way to keep both the SentenceCase and CaptializeAcronyms in the Worksheet_Change event? I'm attaching a small workbook so you can test and see my problem.

Thanks
Gary

[Paul_Hossler]

too much toggling events.

I'd only put the EnableEvents here

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect
    'Sentence Case
    If Not Intersect(Target.Cells(1, 1), Range("B7,B9,B11,B13")) Is Nothing Then
        If Len(Target.Cells(1, 1)) > 0 Then
            SentenceCase Target
            CapitalizeAcronyms Target
        End If
    End If
    ActiveSheet.Protect
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Look at the attachment

[zoom38]

Yes, that was the problem. Solved.

Thanks
Gary

[zoom38]

Good morning, a few months back Paul helped me with a sub to capitalize acronyms within text that is in a cell. It was working great but I reopened this thread because I discovered an issue. As time passed more acronyms have been added to the acronym list so I discovered if a word contains the letters of an acronym within it, it will capitalize those letters. Ex: word = memorandum, acronym on the list = rand, this routine will create memoRANDum as the result. Is there a way to modify this sub to use a space as a delimeter so that the acronym will only be capitalized when it is by itself and not contained within another word.
Below is the sub i am using,

Sub CapitalizeAcronyms(c As Range)
Dim AcronymToFind As String
Dim iSeek As Long, i As Long
Dim lastrow As Long
   
lastrow = Sheets("Acronyms").UsedRange.Rows.count
  With c
      For i = 4 To lastrow
          AcronymToFind = Sheets("Acronyms").Range("B" & i).Value
          If AcronymToFind = "" Then GoTo a
          iSeek = InStr(1, .Value, AcronymToFind, vbTextCompare)
           
          Do While iSeek > 0
              .Value = Left(.Value, iSeek - 1) & UCase(Mid(.Value, iSeek, Len(AcronymToFind))) & Right(.Value, Len(.Value) - iSeek - Len(AcronymToFind) + 1)
              iSeek = InStr(iSeek + Len(AcronymToFind), .Value, AcronymToFind, vbTextCompare)
          GoTo a
          Loop
a:
      Next i
  End With
End Sub

Thanks
Gary

[zoom38]

So I started over and tried using an array with a space as the delimeter. It works as far as isolating the words but I can't figure out how to keep all of the words as well as capitalizing the acronym(s) that it finds. I tried using Redim Preserve but could not get it to work. Below is what I have so far.

Sub CapitalizeAcronyms2(c As Range)
Dim myStringArray() As String
Dim AcronymToFind As String
Dim i As Long, r As Long
Dim lastrow As Long
  
On Error Resume Next

'This splits the value of the cell into an array using a space as the delimeter.
myStringArray() = Split(c, " ")

lastrow = Sheets("Acronyms").UsedRange.Rows.count

For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastrow
         AcronymToFind = Sheets("Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Then
            ReDim Preserve myStringArray(i)
            .Value = UCase(myStringArray(i))
         End If
      Next r
    End With
Next i
End Sub

[zoom38]

I'm almost there, i replaced

 .Value = UCase(myStringArray(i))

with

.Value = Join(myStringArray, " ")

and it works. However, if there is any punctuation attached to the acronym it will not capitalize it. How do I use multiple delimeters in this code?

[zoom38]

The following is what I came up with. It a little long and redundant but I couldn't get it to work any other way. It does what its supposed to but it would be nice to have a more compact sub. Does anyone have a shorter version that works?

Sub CapitalizeAcronyms2(c As Range)
Dim myStringArray() As String
Dim AcronymToFind As String
Dim i As Long, r As Long
Dim lastrow As Long
Dim SplitArr() As String

On Error Resume Next

'This splits the value of the cell into an array using a space as the delimeter.
'myStringArray() = Split(Replace(Replace(Replace(Replace(Replace(c, "!", " "), ",", " "), ":", " "), ";", " "), ".", " "), " ")

myStringArray() = Split(c, " ")
lastrow = Sheets("Acronyms").UsedRange.Rows.count

For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastrow
         AcronymToFind = Sheets("Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "," Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
    End With
Next i

ReDim myStringArray(UBound(myStringArray))
myStringArray() = Split(c, " ")
For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastrow
         AcronymToFind = Sheets("Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "?" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
    End With
Next i

ReDim myStringArray(UBound(myStringArray))
myStringArray() = Split(c, " ")
For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastrow
         AcronymToFind = Sheets("Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "." Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
    End With
Next i

ReDim myStringArray(UBound(myStringArray))
myStringArray() = Split(c, " ")
For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastrow
         AcronymToFind = Sheets("Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "!" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
    End With
Next i

End Sub

[zoom38]

So now i have a rediculously long sub that checks 7 pages of acronyms with punctuation as attached (. , : : ? !) to it or space as a delimeter. Although it works, it is slow. Anyone know or a way to shorten the code? I've been trying but havnt been able to get it right.

Sub CapitalizeAcronyms2(c As Range)
Dim myStringArray() As String
Dim AcronymToFind As String
Dim i As Long, r As Long
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim lastRow3 As Long
Dim lastRow4 As Long
Dim lastRow5 As Long
Dim lastRow6 As Long
Dim lastRow7 As Long
Dim SplitArr() As String

On Error Resume Next

myStringArray() = Split(c, " ")
lastRow1 = Sheets("A1 Acronyms").UsedRange.Rows.count
lastRow2 = Sheets("A2 Acronyms").Range("B" & Rows.count).End(xlUp).Row
lastRow3 = Sheets("C1 Acronyms").Range("B" & Rows.count).End(xlUp).Row
lastRow4 = Sheets("E1 Acronyms").Range("B" & Rows.count).End(xlUp).Row
lastRow5 = Sheets("E2 Acronyms").Range("B" & Rows.count).End(xlUp).Row
lastRow6 = Sheets("E3 Acronyms").Range("B" & Rows.count).End(xlUp).Row
lastRow7 = Sheets("Misc Acronyms").Range("B" & Rows.count).End(xlUp).Row

For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastRow1
         AcronymToFind = Sheets("A1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "," Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow2
         AcronymToFind = Sheets("A2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "," Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow3
         AcronymToFind = Sheets("C1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "," Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow4
         AcronymToFind = Sheets("E1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "," Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow5
         AcronymToFind = Sheets("E2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "," Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow6
         AcronymToFind = Sheets("E3 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "," Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow7
         AcronymToFind = Sheets("Misc Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "," Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
   End With
Next i

ReDim myStringArray(UBound(myStringArray))
myStringArray() = Split(c, " ")
For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastRow1
         AcronymToFind = Sheets("A1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "." Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow2
         AcronymToFind = Sheets("A2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "." Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow3
         AcronymToFind = Sheets("C1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "." Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow4
         AcronymToFind = Sheets("E1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "." Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow5
         AcronymToFind = Sheets("E2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "." Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow6
         AcronymToFind = Sheets("E3 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "." Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow7
         AcronymToFind = Sheets("Misc Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "." Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
   End With
Next i

ReDim myStringArray(UBound(myStringArray))
myStringArray() = Split(c, " ")
For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastRow1
         AcronymToFind = Sheets("A1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ":" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow2
         AcronymToFind = Sheets("A2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ":" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow3
         AcronymToFind = Sheets("C1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ":" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow4
         AcronymToFind = Sheets("E1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ":" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow5
         AcronymToFind = Sheets("E2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ":" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow6
         AcronymToFind = Sheets("E3 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ":" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow7
         AcronymToFind = Sheets("Misc Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ":" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
   End With
Next i

ReDim myStringArray(UBound(myStringArray))
myStringArray() = Split(c, " ")
For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastRow1
         AcronymToFind = Sheets("A1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ";" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow2
         AcronymToFind = Sheets("A2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ";" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow3
         AcronymToFind = Sheets("C1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ";" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow4
         AcronymToFind = Sheets("E1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ";" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow5
         AcronymToFind = Sheets("E2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ";" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow6
         AcronymToFind = Sheets("E3 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ";" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow7
         AcronymToFind = Sheets("Misc Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & ";" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
   End With
Next i

ReDim myStringArray(UBound(myStringArray))
myStringArray() = Split(c, " ")
For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastRow1
         AcronymToFind = Sheets("A1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "?" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow2
         AcronymToFind = Sheets("A2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "?" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow3
         AcronymToFind = Sheets("C1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "?" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow4
         AcronymToFind = Sheets("E1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "?" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow5
         AcronymToFind = Sheets("E2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "?" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow6
         AcronymToFind = Sheets("E3 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "?" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow7
         AcronymToFind = Sheets("Misc Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "?" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
   End With
Next i

ReDim myStringArray(UBound(myStringArray))
myStringArray() = Split(c, " ")
For i = LBound(myStringArray) To UBound(myStringArray)
   With c
      For r = 4 To lastRow1
         AcronymToFind = Sheets("A1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "!" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow2
         AcronymToFind = Sheets("A2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "!" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow3
         AcronymToFind = Sheets("C1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "!" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow4
         AcronymToFind = Sheets("E1 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "!" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow5
         AcronymToFind = Sheets("E2 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "!" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow6
         AcronymToFind = Sheets("E3 Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "!" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
      For r = 3 To lastRow7
         AcronymToFind = Sheets("Misc Acronyms").Range("B" & r).Value
         If UCase(myStringArray(i)) = AcronymToFind Or UCase(myStringArray(i)) = AcronymToFind & "!" Then
            myStringArray(i) = UCase(myStringArray(i))
            .Value = Join(myStringArray, " ")
         End If
      Next r
   End With
Next i
a:
End Sub

Thanks
Gary

[GTO]

Could you give us a fresh example workbook? Easier to see what we're up against...

Mark

[Paul_Hossler]

However, if there is any punctuation attached to the acronym it will not capitalize it.

You mean this ...

The fbi came and said they were fbi.


... becomes this

The FBI came and said they were fbi.


since the second ends with a period?


Also is 'c' a single cell or a range of multiple cells?

Sub CapitalizeAcronyms2(c As Range)

[Paul_Hossler]

Try this

I took your first sample, and made just 3 acronym worksheets. The rest is left as a homework assignment

Option Explicit
Sub drv()
    
    Worksheets("Summary").Range("A1:A20").Value = "The abmy came and said they were abmy. Or was it abmy?"
    CapitalizeAcronyms3 (Worksheets("Summary").Range("A1:A20"))
    MsgBox Worksheets("Summary").Range("A1").Value
    MsgBox Worksheets("Summary").Range("A20").Value
End Sub

Sub CapitalizeAcronyms3(c As Range)
    Const cPunc As String = "(.,:;?!) " '   includes space
    Dim sAcro As String, sText As String, sTemp As String
    Dim a As Variant
    Dim i As Long
    Dim rTemp As Range
    
    a = Application.WorksheetFunction.Transpose(Range(Worksheets("A1_Acronyms").Range("B1"), Worksheets("A1_Acronyms").Range("B1").End(xlDown)))
    sAcro = Join(a, Chr(0)) & Chr(0)
    a = Application.WorksheetFunction.Transpose(Range(Worksheets("A2_Acronyms").Range("B1"), Worksheets("A2_Acronyms").Range("B1").End(xlDown)))
    sAcro = sAcro & Join(a, Chr(0)) & Chr(0)
    a = Application.WorksheetFunction.Transpose(Range(Worksheets("C1_Acronyms").Range("B1"), Worksheets("C1_Acronyms").Range("B1").End(xlDown)))
    sAcro = sAcro & Join(a, Chr(0)) & Chr(0)
    For Each rTemp In c.Cells
        
        sText = rTemp.Value
        sTemp = sText
        For i = 1 To Len(cPunc)
            sTemp = Replace(sTemp, Mid(cPunc, i, 1), Chr(0))
        Next i
    
        a = Split(sTemp, Chr(0))
        
        For i = LBound(a) To UBound(a)
            If InStr(sAcro, UCase(a(i)) & Chr(0)) > 0 Then
                a(i) = UCase(a(i))
            End If
        Next i
        
        sTemp = Join(a, Chr(0))
        For i = 1 To Len(sText)
            If Mid(sTemp, i, 1) <> Chr(0) Then
                Mid(sText, i, 1) = Mid(sTemp, i, 1)
            End If
        Next i
    
        rTemp.Value = sText
    Next
End Sub

[zoom38]

You mean this ...

The fbi came and said they were fbi.


... becomes this

The FBI came and said they were fbi.


since the second ends with a period?

Exactly what I mean.

Also is 'c' a single cell or a range of multiple cells?

Sub CapitalizeAcronyms2(c As Range)

'c' can be a single cell or merged cells.

[zoom38]

Try this

I took your first sample, and made just 3 acronym worksheets. The rest is left as a homework assignment

Option Explicit
Sub drv()
    
    Worksheets("Summary").Range("A1:A20").Value = "The abmy came and said they were abmy. Or was it abmy?"
    CapitalizeAcronyms3 (Worksheets("Summary").Range("A1:A20"))
    MsgBox Worksheets("Summary").Range("A1").Value
    MsgBox Worksheets("Summary").Range("A20").Value
End Sub

Sub CapitalizeAcronyms3(c As Range)
    Const cPunc As String = "(.,:;?!) " '   includes space
    Dim sAcro As String, sText As String, sTemp As String
    Dim a As Variant
    Dim i As Long
    Dim rTemp As Range
    
    a = Application.WorksheetFunction.Transpose(Range(Worksheets("A1_Acronyms").Range("B1"), Worksheets("A1_Acronyms").Range("B1").End(xlDown)))
    sAcro = Join(a, Chr(0)) & Chr(0)
    a = Application.WorksheetFunction.Transpose(Range(Worksheets("A2_Acronyms").Range("B1"), Worksheets("A2_Acronyms").Range("B1").End(xlDown)))
    sAcro = sAcro & Join(a, Chr(0)) & Chr(0)
    a = Application.WorksheetFunction.Transpose(Range(Worksheets("C1_Acronyms").Range("B1"), Worksheets("C1_Acronyms").Range("B1").End(xlDown)))
    sAcro = sAcro & Join(a, Chr(0)) & Chr(0)
    For Each rTemp In c.Cells
        
        sText = rTemp.Value
        sTemp = sText
        For i = 1 To Len(cPunc)
            sTemp = Replace(sTemp, Mid(cPunc, i, 1), Chr(0))
        Next i
    
        a = Split(sTemp, Chr(0))
        
        For i = LBound(a) To UBound(a)
            If InStr(sAcro, UCase(a(i)) & Chr(0)) > 0 Then
                a(i) = UCase(a(i))
            End If
        Next i
        
        sTemp = Join(a, Chr(0))
        For i = 1 To Len(sText)
            If Mid(sTemp, i, 1) <> Chr(0) Then
                Mid(sText, i, 1) = Mid(sTemp, i, 1)
            End If
        Next i
    
        rTemp.Value = sText
    Next
End Sub

Paul, this is perfect. Does exactly what I needed. I was thrown a bit when using it in my file, my acronym sheets had blank rows in them (broken up in groups) and it failed. Removed the blank rows and works awesome.

Thank you.
Gary

[Paul_Hossler]

Didn't understand the need for the 7 worksheets.

You could put all onto a single sheet

[zoom38]

Because there are so many acronyms, its easier to organize them and prevent duplicates by putting on multiple sheets. I haven't created a routine to check the acronyms and add them to the sheets. I may tackle that at another time.

Thanks again for your help.
Gary