Solved: Convert to proper

[Djblois]

I use code I found in a book to covert what the user selects into proper case. However sometimes it takes too long, if they choose too many cells. I have a few ideas to speed it up but I can't figure out how to do it. I have tried a few but I can't get them to work.

Here is the code that I use:

For Each cellobject In Selection
cellobject.Formula = WorksheetFunction.Proper(cellobject.Formula)
cellobject.Replace What:="'S", Replacement:="'s"
Next

Function FinalRow(ByVal shtToCount As Worksheet)
Dim FinalRowD As Long, FinalRowLast As Long

FinalRow = shtToCount.Cells(Rows.Count, 1).End(xlUp).Row
FinalRowD = shtToCount.Cells(Rows.Count, "D").End(xlUp).Row
FinalRowLast = shtToCount.Cells(Rows.Count, FinalColumn(ActiveSheet)).End(xlUp).Row
If FinalRowD > FinalRow Then FinalRow = FinalRowD
If FinalRowLast > FinalRow Then FinalRow = FinalRowLast

End Function
Function FinalColumn(ByVal shtToCount As Worksheet)
Dim FinalColumnD As Long

FinalColumn = Cells(1, Columns.Count).End(xlToLeft).Column
FinalColumnD = Cells(4, Columns.Count).End(xlToLeft).Column
If FinalColumnD > FinalColumn Then FinalColumn = FinalColumnD

End Function



1) I want it to end if the cell is in a row larger than the finalrow
2) I want it to skip an item that is already proper case or if it isn't text or if it is blank

I can't figure it out

[mikerickson]

For Each cellobject In Selection.Cells.SpecialCells(xlCellTypeConstants, 2)will restrict the loop to the cells containing a text constant (no formulas)

[Djblois]

to exit the loop after I get to the last row, I tried



For Each cellobject In Selection
if selection.row > finalrow(Activesheet) then goto EndProper
cellobject.Formula = WorksheetFunction.Proper(cellobject.Formula)
cellobject.Replace What:="'S", Replacement:="'s"
Next


EndProper:

[mikerickson]

instead of looping through Selection loop through


Application.Intersect (Selection, ActiveCell.UsedRange)

That way you can select entire rows, columns or the whole sheet and not go beyond finalRow or finalColumn.

Looping through
Selection.SpecialCells(xlCellTypeConstants, 2).Cells will further restrict your looping to those cells that hold text, no blanks, no formulas, no numbers

[Djblois]

mikerickson

This is what I have now:

For Each cellobject In Application.Intersect _
(Selection.SpecialCells(xlCellTypeConstants, 2).Cells, ActiveCell.UsedRange)
cellobject.Formula = WorksheetFunction.Proper(cellobject.Formula)
cellobject.Replace What:="'S", Replacement:="'s"
Next

and at the moment it doesn't work. It keeps telling me object doesn't support that function

[mikerickson]

I've been wondering what that cellobject.replace line is for. How does the routine do with it commented out? and the For Each statemtent is redundant.
Try this:


On Error Resume Next
For Each cellObject In Selection.SpecialCells(xlCellTypeConstants, 2).Cells
cellObject.Value = Application.Proper(cellObject.Value)
Next cellObject
On Error GoTo 0The error stuff is there in case there are no text constants in the selected range.

[Djblois]

the replace.replace line is because if you use proper anything with a 'S will stay a 'S eg: MIKE'S would become Mike'S with proper. So I replace all the 'S with 's.

[Djblois]

That is working good. But now is there a way to test if it is already proper? and then skip that line?

[mdmackillop]

You can replace all the 'S in one line outwith the loop
Selection.Replace What:="'S", Replacement:="'s"

[mikerickson]

It would be faster to put this line outside of the loop. It takes care of the entire sheet.
Cells.Replace What:="'S", Replacement:="'s", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False

But now is there a way to test if it is already proper?
Other than checking letter by letter, I know of none.

[Djblois]

You know I never thought about that but you are correct. lol

[Djblois]

Now I have this:

Selection.SpecialCells(xlCellTypeConstants, 2).Formula = _
Application.Proper(Selection.Value) 'Change selection to proper case
Selection.Replace What:="'S", Replacement:="'s" 'Change 'S to 's

Much quicker, works on thousands of cells. The old way if you had to do 30,000 rows, it would lock up. The only other thing I wish it is possible to do is check if the content is proper before changing it. Anybody else know if this is possible?

[mdmackillop]

Even if it were possible, would it be quicker?

[Djblois]

it is a trade off sometimes it would be wouldn't it? Acutually you just made me think, it won't be because I will have to put it back in the loop to be able to test it. Thank you all for your help.

[malik641]

Now I have this:

Selection.SpecialCells(xlCellTypeConstants, 2).Formula = _
Application.Proper(Selection.Value) 'Change selection to proper case
Selection.Replace What:="'S", Replacement:="'s" 'Change 'S to 's

Much quicker, works on thousands of cells. The old way if you had to do 30,000 rows, it would lock up. The only other thing I wish it is possible to do is check if the content is proper before changing it. Anybody else know if this is possible?
I thought there was a way to do this without a loop. I couldn't think of how, though. Nice solution Djblois :thumb It's awesome :yes

[mikerickson]

Now I have this:

Selection.SpecialCells(xlCellTypeConstants, 2).Formula = _
Application.Proper(Selection.Value) 'Change selection to proper case
Selection.Replace What:="'S", Replacement:="'s" 'Change 'S to 's

Much quicker, works on thousands of cells. The old way if you had to do 30,000 rows, it would lock up. The only other thing I wish it is possible to do is check if the content is proper before changing it. Anybody else know if this is possible?

There is a problem with this code. I put "a" in A1, "b" in B2, and so on down the diagonal, leaving the other cells blank. When I ran the code, all the cells turned to "A". When I tested with a rectagularly filled area, it worked fine. I suspect that the Application.Proper is only working on the first area of the .Special Cells. If that is the case, looping through the areas will be faster than looping through cells.

[mdmackillop]

Here's a non-looping solution
Application.ScreenUpdating = False
With Selection
.Offset(, 5).FormulaR1C1 = "=Proper(RC[-5])"
.Offset(, 5).Copy
.PasteSpecial xlValues
.Offset(, 5).ClearContents
.Replace What:="'S", Replacement:="'s" 'Change 'S to 's
End With
Application.ScreenUpdating = True

[johnske]

Here's a non-looping solution
Application.ScreenUpdating = False
With Selection
.Offset(, 5).FormulaR1C1 = "=Proper(RC[-5])"
.Offset(, 5).Copy
.PasteSpecial xlValues
.Offset(, 5).ClearContents
.Replace What:="'S", Replacement:="'s" 'Change 'S to 's
End With
Application.ScreenUpdating = True

Nice Malcolm,
A slight variation on that - eliminates copy/paste and works on 'used range' for a column you specify instead of 'Selection'

Option Explicit

Sub ChangeToProper()
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.Columns(1) '< change 1 to suit
.Offset(0, 5).FormulaR1C1 = "=Proper(RC[-5])"
.Value = .Offset(0, 5).Value '< change 5 to suit
.Offset(0, 5).ClearContents '< change 5 to suit
.Replace "'S", "'s" 'Change 'S to 's
End With
Application.ScreenUpdating = True
End Sub

[mdmackillop]

Thanks John,
Much neater.

[Djblois]

You made me do further testing. All of them have the same problem. If there is one blank in the range selected it messes everything up.

Here this one works the best:

With selection '< change 1 to suit
.Offset(0, 100).FormulaR1C1 = "=Proper(RC[-100])"
.Value = .Offset(0, 100).Value '< change 5 to suit
.Offset(0, 100).ClearContents '< change 5 to suit
.Replace "'S", "'s" 'Change 'S to 's
End With


I made one change, I changed 5 to 100 because there is a good chance that there will be data in 5 coulumns over. There is a much better chance of there being no data in 100 columns over.

[mdmackillop]

Convert as you go
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
With Target
If .Column = 2 Then
.Value = WorksheetFunction.Proper(.Value)
.Replace "'S", "'s"
End If
End With
Application.EnableEvents = True
End Sub