PDA

View Full Version : [SOLVED] Captilize Select Characters Within A Cell



zoom38
04-04-2016, 06:57 AM
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
04-04-2016, 08:19 AM
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
04-04-2016, 08:27 AM
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
04-04-2016, 10:36 AM
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
04-04-2016, 10:59 AM
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
04-04-2016, 11:02 AM
Yes, that was the problem. Solved.

Thanks
Gary

zoom38
09-07-2017, 07:21 AM
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
09-07-2017, 09:18 AM
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
09-07-2017, 02:27 PM
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
09-07-2017, 05:21 PM
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
09-08-2017, 09:30 AM
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
09-11-2017, 05:07 AM
Could you give us a fresh example workbook? Easier to see what we're up against...

Mark

Paul_Hossler
09-11-2017, 07:03 AM
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
09-11-2017, 07:57 AM
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
09-11-2017, 04:44 PM
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
09-11-2017, 04:48 PM
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
09-11-2017, 06:25 PM
Didn't understand the need for the 7 worksheets.

You could put all onto a single sheet

zoom38
09-11-2017, 06:53 PM
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