Excel VBA - Loop through cells and change capitalisation based on length

[neodjandre]

I am currently using this procedure which basically changes the capitalisation for all cells in a column and it works fine.

Sub sanitise_data()

x_import.Activate

 With x_import.Range("A1", Cells(Rows.Count, "A").End(xlUp))
        .value = Evaluate("INDEX(Proper(" & .Address(External:=True) & "),)")
    End With
    
End Sub

The data is all in caps:

RUGBY UNION
WTA TOUR 500
WTA TOUR 1000
PGA TOUR CHAMPIONS
ATP 250
ATP 500
PGA TOUR
EIHL
EIHL
PREMIER LEAGUE
AEW
NHL
EUROPA LEAGUE
NHL
NHL
NBA
NHL
NHL
NBA
HARLEM GLOBETROTTERS 2022 SPREAD GAME TOUR

I am looking to add another loop to change back certain words to all CAPS such as EIHL, WTA,NHL,NBA etc.. which I can define in a VBA array perhaps. The function should be smart enough to analyse each word in each cell I presume.

much appreciate your help.

 

[JamesCanale]

I made a no-VBA version since this wasn't getting a lot of traction out there.

MrExcelPlayground7.xlsx
	A	B	C	D
1	RUGBY UNION	Rugby Union		EIHL
2	WTA TOUR 500	WTA Tour 500		WTA
3	WTA TOUR 1000	WTA Tour 1000		NHL
4	PGA TOUR CHAMPIONS	PGA Tour Champions		NBA
5	ATP 250	ATP 250		AEW
6	ATP 500	ATP 500		PGA
7	PGA TOUR	PGA Tour		ATP
8	EIHL	EIHL
9	EIHL	EIHL
10	PREMIER LEAGUE	Premier League
11	AEW	AEW
12	NHL	NHL
13	EUROPA LEAGUE	Europa League
14	NHL	NHL
15	NHL	NHL
16	NBA	NBA
17	NHL	NHL
18	NHL	NHL
19	NBA	NBA
20	HARLEM GLOBETROTTERS 2022 SPREAD GAME TOUR	Harlem Globetrotters 2022 Spread Game Tour
Sheet11

Cell Formulas
Range	Formula
B1:B20	B1	=TEXTJOIN(" ",TRUE,IF(ISNA(VLOOKUP(FILTERXML("<x><y>"&SUBSTITUTE(A1," ","</y><y>")&"</y></x>","//y"),D:D,1,FALSE)),PROPER(FILTERXML("<x><y>"&SUBSTITUTE(A1," ","</y><y>")&"</y></x>","//y")),FILTERXML("<x><y>"&SUBSTITUTE(A1," ","</y><y>")&"</y></x>","//y")))

 

[rollis13]

Hi to all.
Here is what I came up with:

Option Explicit
Sub sanitise_data()
    Dim x_import As Worksheet
    Dim myArray As Variant
    Dim myCells As Long
    Dim x      As Long
    Dim first  As Long
    Dim intPos As Integer
    Set x_import = Sheets("Sheet1")               '<- change sheet name as needed
    x_import.Activate
    With Range("A1", Cells(Rows.Count, "A").End(xlUp))
        .Value = Evaluate("INDEX(Proper(" & .Address(External:=True) & "),)")
    End With
    myArray = Array("EIHL", "WTA", "NHL", "NBA")  '<- add items as needed
    For myCells = 1 To Range("A" & Rows.Count).End(xlUp).Row
        first = 1
        For x = LBound(myArray) To UBound(myArray)
            intPos = InStr(first, Range("A" & myCells), myArray(x), vbTextCompare)   'search item in cell
            If intPos > 0 Then
                Do
                    Range("A" & myCells) = Left(Range("A" & myCells), intPos - 1) & UCase(myArray(x)) & _
                              Mid(Range("A" & myCells), intPos + Len(myArray(x)), Len(Range("A" & myCells)) - intPos + Len(myArray(x)))
                    first = intPos + Len(myArray(x))
                    intPos = InStr(first, Range("A" & myCells), myArray(x), vbTextCompare)
                Loop While intPos > 0             'loop for repeated item in cell
            End If
        Next x
    Next myCells
    MsgBox "Done!"
End Sub

 

[Peter_SSs]

Some general code comments first. Since you are activating** x_import
- there is no need to prefix Range("A1") with x_import
- there is no need for the evaluate address to be External
- I'm not sure why you have the INDEX in your evaluate line as I can't see that it is needed

** Generally there is no need to activate sheets to work with them. However, when using Evaluate it can be a good idea since the (often very long) External address required may possibly cause some other issues.

Anyway, this would be my changes/additions to your code.

Dim a As Variant, aWords As Variant
Dim i As Long, j As Long
Dim UCaseWords As String

UCaseWords = ",EIHL,WTA,NHL,NBA," '<- Add more as required
x_import.Activate
With Range("A1", Cells(Rows.Count, "A").End(xlUp))
   .Value = Evaluate("Proper(" & .Address & ")")
   a = .Value
   For i = 1 To UBound(a)
    aWords = Split(a(i, 1))
    For j = 0 To UBound(aWords)
      If InStr(1, UCaseWords, "," & aWords(j) & ",", 1) > 0 Then aWords(j) = UCase(aWords(j))
    Next j
    a(i, 1) = Join(aWords)
   Next i
   .Value = a
End With

 

[neodjandre]

I came up with this:

Sub sanitise_data(sh As Worksheet, col As String)
Dim cell As Range
Dim rng As Range
Dim data As Variant
Dim i As Long

sh.Activate

'Convert Data to Proper Case
With sh
    Set rng = Range(col & "1", Cells(Rows.Count, col).End(xlUp))
    data = .Evaluate("INDEX(Proper(" & rng.Address & "),)")
End With

'Capitalise Exceptions
For i = 1 To UBound(data)
    If IsCap(data(i, 1)) Then data(i, 1) = UCase(data(i, 1))
Next i

rng.Offset(, 0) = data
End Sub

Function IsCap(ByVal s) As Boolean
Const Delim As String = ","
Dim Caps As Variant
    Caps = Split("Eihl,Wta,Nhl,Nba,Nfl", Delim)
IsCap = UBound(Filter(Caps, Split(s & " ")(0))) > -1
End Function

But it's a bit buggy when it comes to things like "Men'S" and "Women'S" and also for some reason TOUR stays capitalised even if its not in the exception list - will test your code now

 

[neodjandre]

Some general code comments first. Since you are activating** x_import
- there is no need to prefix Range("A1") with x_import
- there is no need for the evaluate address to be External
- I'm not sure why you have the INDEX in your evaluate line as I can't see that it is needed

** Generally there is no need to activate sheets to work with them. However, when using Evaluate it can be a good idea since the (often very long) External address required may possibly cause some other issues.

Anyway, this would be my changes/additions to your code.

Dim a As Variant, aWords As Variant
Dim i As Long, j As Long
Dim UCaseWords As String

UCaseWords = ",EIHL,WTA,NHL,NBA," '<- Add more as required
x_import.Activate
With Range("A1", Cells(Rows.Count, "A").End(xlUp))
   .Value = Evaluate("Proper(" & .Address & ")")
   a = .Value
   For i = 1 To UBound(a)
    aWords = Split(a(i, 1))
    For j = 0 To UBound(aWords)
      If InStr(1, UCaseWords, "," & aWords(j) & ",", 1) > 0 Then aWords(j) = UCase(aWords(j))
    Next j
    a(i, 1) = Join(aWords)
   Next i
   .Value = a
End With

Peter I think your code is better to use. but it has the same problem with Men'S and Women'S

 

[neodjandre]

I just ended up adding this at the end to fix the apostrophe bug - in case someone else needs to refer to this.

    .Replace What:="'S", Replacement:="'s", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False

 

[rollis13]

This is what you said in post #1:

basically changes the capitalisation for all cells in a column and it works fine.

How come you are now complaining about this (not even in your example):

buggy when it comes to things like "Men'S" and "Women'S"

 

[Peter_SSs]

also for some reason TOUR stays capitalised even if its not in the exception list

The word "tour" is not the problem. The problem is that the logic of your code is that if the first word in the cell is in the exception list then it capitalises the whole cell text.
See the coloured cells below which is your code (I adjusted the results offset to ,1) and produces all capitals if the first word is in the list (amber) but "tour" (& everything else) is fine when the first word is not in the list (green).

Also note your code's dealing with rows 15 & 16 (blue), if it is possible to have data like that.

As I mentioned before, INDEX does nothing in your "Evaluate" line other than add extra processing so you might as well get rid of it.

You could try this code that addresses all the above issues and also deals with the 'S on the way through. Results are offset ,2 in my code.

Sub sanitise_data_PSSs_1(sh As Worksheet, col As String)
  Dim a As Variant, aWords As Variant
  Dim i As Long, j As Long
  Dim UCaseWords As String
  
  UCaseWords = ",Eihl,Wta,Nhl,Nba,Nfl," '<- Add more as required
  sh.Activate
  With Range("A1", Cells(Rows.Count, "A").End(xlUp))
     a = Evaluate("substitute(proper(substitute(" & .Address & ",""'S"",""z'z"")),""z'Z"",""'s"")")
     For i = 1 To UBound(a)
      aWords = Split(a(i, 1))
      For j = 0 To UBound(aWords)
        If InStr(1, UCaseWords, "," & aWords(j) & ",", 1) > 0 Then aWords(j) = UCase(aWords(j))
      Next j
      a(i, 1) = Join(aWords)
     Next i
     .Offset(, 2).Value = a
  End With
End Sub

neodjandre.xlsm
	A	B	C
1	RUGBY UNION	Rugby Union	Rugby Union
2	WTA TOUR 500	WTA TOUR 500	WTA Tour 500
3	PGA TOUR CHAMPIONS	Pga Tour Champions	Pga Tour Champions
4	ATP 250	Atp 250	Atp 250
5	PGA TOUR	Pga Tour	Pga Tour
6	EIHL	EIHL	EIHL
7	PREMIER LEAGUE	Premier League	Premier League
8	AEW	Aew	Aew
9	NHL	NHL	NHL
10	EUROPA LEAGUE	Europa League	Europa League
11	NHL	NHL	NHL
12	NBA	NBA	NBA
13	NHL HARLEM GLOBETROTTERS 2022 SPREAD GAME TOUR	NHL HARLEM GLOBETROTTERS 2022 SPREAD GAME TOUR	NHL Harlem Globetrotters 2022 Spread Game Tour
14	MEN'S COMP	Men's Comp	Men's Comp
15	O'CONNOR LEAGUE	O'connor League	O'Connor League
16	PREMIER NHL LEAGUE	Premier Nhl League	Premier NHL League
Sheet3