View Full Version : Solved: search for words in all caps in Excel
Hello everyone,
this macro is able to identify and re-format only cells
containing words in all caps but not when in the same cell I have some words in all caps and some in lowercase. Any help ?
thanks in advance
sasa
Sub OnlyUpper()
Dim cell As Range
For Each cell In Selection
If cell.Value = UCase(cell.Value) Then
cell.Font.ColorIndex = 3 'make font color = red
End If
Next
End Sub
Greetings Sasa,
Your code would seem to produce the results of what it appears you want it to do. Would you please re-state what you want the code to do?
Thank you so much,
Mark
Well, if in the same cell I have John MARK together it does not work. On the contrary if I have MARK alone in one cell it works,
Thanks in advance
Sub OnlyUpper()
For Each cl In Selection.specialcells(2,2)
for j=1 to len(cl)
if asc(mid(cl,j,1))>64 and asc(mid(cl,j,1))<91 Then exit for
next
if j<=len(cl) then cell.Font.ColorIndex = 3
Next
End Sub
Thank you a lot, but something is wrong.
The macro gets stuck here "If j <= Len(cl) Then cell.Font.ColorIndex = 3"
sasa
Sub OnlyUpper()
For Each cl In Selection.specialcells(2,2)
For j=1 To len(cl)
If asc(mid(cl,j,1))>64 And asc(mid(cl,j,1))<91 Then exit For
Next
If j<=len(cl) Then cl.Font.ColorIndex = 3
Next
End Sub
I am sorry but now all the text get the red color.
no distinction between uppper case and lower case
sasa
Please reformulate your question.
This is what I neeed.
Thanks again
sasa
A guess, as I cannot read .xlsx/.xlsm at moment. If this is off, please post your example Before/After WB in .xls format.
In a Standard Module:
Option Explicit
Sub OnlyUpper()
Dim REX As Object ' VBScript_RegExp_55.RegExp
Dim rexCOL As Object ' MatchCollection
Dim rexMatch As Object ' Match
Dim Cell As Range
Dim strNon As String
Dim strTemp As String
Dim strLeft As String
Dim strRight As String
Dim PosStart As Long
Dim lLen As Long
Dim n As Long
Dim arrPosAndLen As Variant
Set REX = CreateObject("VBScript.RegExp")
With REX
.Global = True
.IgnoreCase = False
'// I have forgotten what tiny bit I knew, but this should be any letter, UPPER //
'// or lower case, where a word boundary is determined to exist in front and //
'// following the letter(s). //
.Pattern = "\b[a-zA-Z]+\b"
For Each Cell In Selection
'// Start fresh //
strLeft = vbNullString
strRight = vbNullString
arrPosAndLen = Empty
'// The test is just to see if we can get a MatchCollection, and does NOT //
'// indicate that there are any UPPERCASE 'words'. //
If .Test(Cell.Value) Then
'ReDim arrPosAndLen(1 To 2, 0 To 0)
'// reset to -1 so we start plunking into the correct element. //
n = -1
'// Start out with the cell's value plunked into one string variable, //
'// which we'll move piece-by-piece to allow InStr() to return the //
'// position and length of the 'word' needing colored. //
strRight = Cell.Value
Set rexCOL = .Execute(strRight)
For Each rexMatch In rexCOL
'// Get the start position and length of this Match //
PosStart = InStr(1, strRight, rexMatch)
lLen = rexMatch.Length
If UCase(rexMatch.Value) = rexMatch.Value Then
'// IF we find at least one 'word' in UPPERCASE, then change to //
'// an array. //
If Not IsArray(arrPosAndLen) Then
ReDim arrPosAndLen(1 To 2, 0 To 0)
End If
'// Resize and Preserve as necessary. //
n = n + 1
ReDim Preserve arrPosAndLen(1 To 2, 0 To n)
'// strLeft will grow in 2nd thru x loops, so we can add it to //
'// the current returned position to return where the word exists/
'// in the original string. //
arrPosAndLen(1, n) = PosStart + Len(strLeft)
arrPosAndLen(2, n) = lLen
'// Shift string //
strNon = Left(strRight, PosStart - 1)
strTemp = Mid(strRight, PosStart, lLen)
strLeft = strLeft & strNon & strTemp
strRight = Mid(strRight, PosStart + lLen)
Else
'// Just shift without noting, as the 'word' was not a match. //
strLeft = strLeft & Left(strRight, PosStart + lLen - 1)
strRight = Mid(strRight, PosStart + lLen)
End If
Next
'// IF we had one or more 'word(s)', then arrPosAndLen will be an array;//
'// so we'll loop thru and change the characters. //
If IsArray(arrPosAndLen) Then
For n = 0 To UBound(arrPosAndLen, 2)
If Not arrPosAndLen(1, n) = Empty Then
Cell.Characters(Start:=arrPosAndLen(1, n), _
Length:=arrPosAndLen(2, n)).Font.ColorIndex = 3
End If
Next
End If
End If
Next
End With
End Sub
Hope that helps,
Mark
Sub Red_snb()
For Each cl In Selection.SpecialCells(2, 2)
If cl = UCase(cl) Then
cl.Font.ColorIndex = 3
Else
y = 0
For j = 1 To Len(cl)
If Asc(Mid(cl, j, 1)) > 64 And Asc(Mid(cl, j, 1)) < 91 Then
If y = 0 Then y = j
Else
If y > 0 Then
cl.Characters(y, j -y).Font.ColorIndex = 3
y = 0
End If
End If
Next
If y > 0 Then cl.Characters(y, j - y).Font.ColorIndex = 3
End If
Next
End Sub
Thanks, they work fine. Solved.
Sasa
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.