PDA

View Full Version : Solved: search for words in all caps in Excel



sasa
01-27-2013, 03:24 AM
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

GTO
01-27-2013, 04:02 AM
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

sasa
01-27-2013, 04:31 AM
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

snb
01-27-2013, 05:23 AM
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

sasa
01-27-2013, 06:01 AM
Thank you a lot, but something is wrong.
The macro gets stuck here "If j <= Len(cl) Then cell.Font.ColorIndex = 3"

sasa

snb
01-27-2013, 06:49 AM
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

sasa
01-27-2013, 07:31 AM
I am sorry but now all the text get the red color.
no distinction between uppper case and lower case

sasa

snb
01-27-2013, 07:51 AM
Please reformulate your question.

sasa
01-27-2013, 08:53 AM
This is what I neeed.

Thanks again

sasa

GTO
01-27-2013, 07:33 PM
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

snb
01-28-2013, 02:17 AM
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

sasa
01-28-2013, 07:25 AM
Thanks, they work fine. Solved.
Sasa