Capitalize first character & spacing - Excel

Hi folks,
When a user moves from a column (say col A) in excel after typing something, we need to ensure that any character following a period (.) should be capitalised and the spacing between the period and the character should be just 1 space. Can somebody post a snippet.
Thankz :wave:

all new sentences in an excel cell seem to auto capitalise the first character, though i expect there is a setting for that somewhere, and the first character in the cell could be in lowercase, here is some code to do what you asked

first you have to know which cell you are leaving
it won't work for the first cell you leave in a newly opened sheet

vb Code:

Dim prev As Range   ' range to leave
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not prev Is Nothing Then
    If prev.Column = 1 Then  ' column A
        pos = InStr(prev.Value, ".")
        If pos > 0 Then   ' period in cell
            myarr = Split(prev.Value, ".")  ' divide sentences into arrray
            For i = 0 To UBound(myarr)
                myarr(i) = Trim(myarr(i))
                If Len(myarr(i)) > 0 Then myarr(i) = UCase(Left(myarr(i), 1)) & Mid(myarr(i), 2)
            Next
            prev.Value = Join(myarr, ". ")
        End If
    End If
End If
Set prev = Target 'set range for next cell to leave
End Sub

Thanks for the response :thumb: You did give me a similar code earlier.

Quote:

---

all new sentences in an excel cell seem to auto capitalise the first character, though i expect there is a setting for that somewhere

---

Yes it is part of autocorrect options.
I have come this far using codes provded by members..

vbcode Code:

Private Sub Worksheet_Change(ByVal Target As Range)
'courtesy anhn
'http://www.vbforums.com/showthread.php?t=498843
    With Target
        If .Formula = "" Then
            Exit Sub
        Else
            If .Column <> xl_ColNo("B") Then
                .Formula = UCase(.Formula)
            ElseIf .Column = xl_ColNo("B") Then
                .Formula = RemoveXtraSpaces(.Formula)
            End If
        End If
    End With
End Sub
Function xl_ColNo(Col_Name As String) As Integer
'courtesy si_the_geek
'returns an Excel column number from its name (e.g.: col_name "AA" returns  27)
 
      Col_Name = UCase(Trim(Col_Name))
      
      Select Case Len(Col_Name)
        Case 1:     xl_ColNo = Asc(Col_Name) - 64
        Case 2:     xl_ColNo = ((Asc(Left(Col_Name, 1)) - 64) * 26) _
                        + (Asc(Right(Col_Name, 1)) - 64)
      End Select
End Function
 
Public Function RemoveXtraSpaces(strVal As String) As String
    Do While InStr(1, strVal, "  ")
        strVal = Replace(strVal, "  ", " ")
    Loop
    RemoveXtraSpaces = strVal
End Function

Can this be imporved. Iam also now to work on the Title case....

titlecase sets the first letter of every word, not just the first in a sentance

the code i posted, was just in response to the question in your OP, it removes all extra spaces after a period and set the first character to uppercase

Sorry I mixed up words, I wanted to say Sentence case ::D:

vbcode Code:

Dim prev As Range   ' range to leave
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Not prev Is Nothing Then
    If prev.Column = 1 Then  ' column A
        pos = InStr(prev.Value, ".")
        If pos > 0 Then   ' period in cell
            myarr = Split(prev.Value, ".")  ' divide sentences into arrray
            For i = 0 To UBound(myarr)
                myarr(i) = Trim(myarr(i))
                If Len(myarr(i)) > 0 Then myarr(i) = UCase(Left(myarr(i), 1)) & Mid(myarr(i), 2)
            Next
            prev.Value = Join(myarr, ". ")
        End If
    End If
End If
Set prev = Target 'set range for next cell to leave
End Sub

this code is not working :confused: the extra spaces remain as it was....
Edit: The code works after I remove On Error Resume Next.

pls also see the below code. The whole thing goes into some kind of infinite loop.

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)

Dim strArray() As String
Dim i As Long
    With Target
        If .Formula = "" Then
            Exit Sub
        Else
            If .Column <> xl_ColNo("B") Then
                .Formula = UCase(.Formula)
            ElseIf .Column = xl_ColNo("B") Then
                '.Formula = UCase(Mid(.Formula, 1, 1)) & Mid(.Formula, 2, Len(.Formula))
                .Formula = RemoveXtraSpaces(.Formula)
                strArray = Split(.Formula, ".")
                For i = 0 To UBound(strArray)
                    strArray(i) = UCase(Left(strArray(i), 1)) & Mid(strArray(i), 2)
                    'If Len(strArray(i)) > 0 Then
                Next i
                .Formula = Join(strArray, ".")
                Exit Sub
            End If
        End If
    End With

End Sub

---

As mentioned in one of your thread before, you should use
Worksheet_Change event (fired when content of one or more cells changed)
instead of
Worksheet_SelectionChange event (fired when cell cursor moved regardless of cell value changed or not.)

Below is the best code to do your task.

• Check how the WorksheetFunction.Trim() works, that is not the same as VB Trim() function.
• Note that Target is a range that may contains more than one cell.
• It works for each cell when user paste multiple cells at the same time.
• This code also removes any space before a dot.
• Split() uses ". " (dot and space) as delimeter after a sequence of {Replace(), Trim(), Replace()}

Code:

---

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
'==== Courtesy anhn ===============================
  Dim aCell      As Range
  Dim sText      As String
  Dim Sentences() As String
  Dim i          As Integer
 
  '  ** If you want to auto update only values of cells in a particular range
  '      then do checking whether Target is in this range or not by
  '      Replacing line (0) with lines (1),(2),(3),(4) below:
  For Each aCell In Target.Cells '-- line (0): No restriction on Target
  'Dim aRange As Range                              '-- line (1)
  '-------------------------------------------------
  'Set aRange = Intersect(Target, Me.Range("B:B"))  '-- line (2)a
  'Set aRange = Intersect(Target, Me.Range("C:D"))  '-- line (2)b
  'Set aRange = Intersect(Target, Me.Range("3:5"))  '-- line (2)c
  'Set aRange = Intersect(Target, Me.Range("C2:H8")) '-- line (2)d
  '-------------------------------------------------
  'If aRange Is Nothing Then Exit Sub                '-- line (3)
  'For Each aCell In aRange.Cells                    '-- line (4)
      sText = aCell.Formula
      If Len(sText) = 0 Then '-- Blank cell
        '-- Do nothing
      ElseIf Left(sText, 1) <> "=" Then '-- Cell without formula
        '-- Add a space after every dot by replacing "." with ". "
        '  Do this to fix the case no space after dot: x.y
        sText = Replace(sText, ".", ". ")
        '-- Use Worksheet Trim function to trim leading and trailing spaces,
        '  it also trim all middle multiple spaces to single space.
        '  Note that VB Trim() function does not trim middle multiple spaces.
        sText = WorksheetFunction.Trim(sText)
        '-- Remove space before dot
        sText = Replace(sText, " .", ".")
        '-- Split sText to sentences by ". " (not effect the very last dot if exist)
        Sentences = Split(sText, ". ")
        '-- Capitalize first letter of each sentence
        For i = 0 To UBound(Sentences)
            If Len(Sentences(i)) > 0 Then
              Sentences(i) = UCase(Left(Sentences(i), 1)) & Mid(Sentences(i), 2)
            End If
        Next
        '-- Rejoin Sentences to sText with ". " (not effect the very last dot if exist)
        sText = Join(Sentences, ". ")
        '-- Replace Target.Formula with new value of sText
        aCell.Formula = sText
      End If
  Next
End Sub

---

This is something I like with the members of this forum

Quote:

---

ElseIf Left(sText, 1) <> "=" Then '-- Cell without formula

---

giving more help than requested for :thumb: :thumb: :D
Anhn, please also let me know why my sloppy code was going on tipsy :hick: infinite loop ;)

Anhn, I need to trouble you more :cry:
Can you further help in making a sub or function to perform the same task with optional choice of charcters (it could be more than one) in the place of period (.) like ?! etc :wave:

Try this (simplified version):

Code:

---

Option Explicit
Const EndChars = ".?!:"
Const Marker = "§" '-- Chr(167)
'-- Chr(167) can be replaced with any unused character
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim aCell      As Range
  Dim sText      As String
  Dim Sentences() As String
  Dim i          As Integer
  Dim ch          As String * 1
 
  For Each aCell In Target.Cells '-- line(0): No restriction on Target
      sText = aCell.Formula
      '-- Update only non-blank cell without formula
      If Len(sText) > 0 And Left(sText, 1) <> "=" Then
        For i = 1 To Len(EndChars)
            ch = Mid(EndChars, i, 1)
            '-- add Marker to any ending character
            sText = Replace(sText, ch, ch & Marker)
        Next
        '-- split by Marker
        Sentences = Split(sText, Marker)
        '-- Trim and Capitalize first letter of each sentence
        For i = 0 To UBound(Sentences)
            Sentences(i) = WorksheetFunction.Trim(Sentences(i))
            If Len(Sentences(i)) > 0 Then
              Sentences(i) = UCase(Left(Sentences(i), 1)) & Mid(Sentences(i), 2)
            End If
        Next
        '-- re-join with spaces
        sText = Join(Sentences, " ")
        If aCell.Formula <> sText Then
            aCell.Formula = sText
        End If
      End If
  Next
End Sub

---

I believe I have misguided you with my sloppy queries :cry:

Code:

---

'-- line(0): No restriction on Target

---

I do want to implement the restriction as found in #8. In addition to that I want to reuse the code. Meaning, I need the code to run only for certain sheets/columns. So if a sub/func is created, then I can, hopefully :lol:, attempt to pass them (sheets,cols) as parameters when ever sheet change event occurs.
something like

Code:

---

Private Sub MonitorData(sheetName,column(s))
'Code to manipulate the data
End sub

---

Couldnt you just use the trim function?
the second one doesnt work, but the firts does....

Code:

---

msgbox Application.Worksheetfunction.Trim ("hello  there are too many    spaces.")

msgbox Trim ("hello  there are too many    spaces.")

---

Quote:

---

Couldnt you just use the trim function?

---

I believe anhn had answered in post #8
'

Quote:

---

-- Use Worksheet Trim function to trim leading and trailing spaces,
' it also trim all middle multiple spaces to single space.
' Note that VB Trim() function does not trim middle multiple spaces.

---

May i ask you a question about Excel?

Do you have the time for a simple question or two?


I have a list in a column of last names. Some are in all capitol letters.

Is there a way to have only the first letter upper case and the rest of the word in lower case.

Also, I am not an advanced geek. If you are going to suggest a code thing, could you give me the baby steps to insert code.

Thank you and please advise.


edit by admin: no contact info permitted on the forum, thank you

Quote:

---

Originally Posted by VBFnewcomer

I do want to implement the restriction as found in #8. In addition to that I want to reuse the code. Meaning, I need the code to run only for certain sheets/columns. So if a sub/func is created, then I can, hopefully :lol:, attempt to pass them (sheets,cols) as parameters when ever sheet change event occurs.

---

1. Add this Sub in a Module:

Code:

---

Public Sub SentenceCase(ByVal Target As Range)
  Const EndChars = ".?!:"
  Const Marker = "§" '-- Chr(167) : can be replaced with any unused character
  Dim aCell      As Range
  Dim sText      As String
  Dim Sentences() As String
  Dim i          As Integer
  Dim ch          As String * 1
 
  For Each aCell In Target.Cells
      sText = aCell.Formula
      '-- Update only non-blank cell without formula
      If Len(sText) > 0 And Left(sText, 1) <> "=" Then
        For i = 1 To Len(EndChars)
            ch = Mid(EndChars, i, 1)
            sText = Replace(sText, ch, ch & Marker) '-- add Marker to any ending character
        Next
        Sentences = Split(sText, Marker) '-- split by Marker
        '-- Trim and Capitalize first letter of each sentence
        For i = 0 To UBound(Sentences)
            Sentences(i) = WorksheetFunction.Trim(Sentences(i))
            If Len(Sentences(i)) > 0 Then
              Sentences(i) = UCase(Left(Sentences(i), 1)) & Mid(Sentences(i), 2)
            End If
        Next
        sText = Join(Sentences, " ") '-- re-join with spaces
        If aCell.Formula <> sText Then aCell.Formula = sText
      End If
  Next
End Sub

---

2a. Add this code to ThisWorkbook module if you want to use only one place for more than one worksheets:

Code:

---

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Dim NewTarget As Range
 
  Select Case Sh.Name
      Case "Sheet1" '-- change to suit your need
        '-- change "A:C" to what you want
        Set NewTarget = Intersect(Target, Sh.Range("A:C"))
      Case "Sheet2" '-- change to suit your need
        '-- change "A1:C10" to what you want
        Set NewTarget = Intersect(Target, Sh.Range("A1:C10"))
      Case "Sheet3" '-- change to suit your need
        '-- change "2:5" to what you want
        Set NewTarget = Intersect(Target, Sh.Range("2:5"))
        '-- for multiple ranges, use Union
        'Set NewTarget = Intersect(Target, Union(Sh.Range("2:5"), Sh.Range("A6:D10")))
  End Select
  If Not (NewTarget Is Nothing) Then
      SentenceCase NewTarget
  End If
End Sub

---

2b. Add this code to a Sheet module if you want to have separate code for each sheet:

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim NewTarget As Range
  '-- change Me.Range("A:C") to whatever you want such as:
  '  Me.Range("A1:C10"),
  '  Me.Range("2:5"),
  '  or use union for multiple ranges:
  '  Union(Me.Range("2:5"), Me.Range("A6:D10"))
  Set NewTarget = Intersect(Target, Me.Range("A:C"))
  If Not (NewTarget Is Nothing) Then
      SentenceCase NewTarget
  End If
End Sub

---

Code:

---

Option Explicit

'When a user moves from a column (say col A) in excel after typing something,
'we need to ensure that
'  any character following a period (.) should be capitalised
'  and the spacing between the period and the character should be just 1 space
'
' For testing row 1, same column will have results
'
Dim thC As Range, recur As Boolean, thcD As String, x As Integer, y As Integer, z As Integer
Dim r1 As String, r2 As String, r3 As String
Const EndChars = ".?!:"
Private Sub Worksheet_Change(ByVal Target As Range)
    'Application.AutoCorrect.CorrectSentenceCap = False 'this turns off auto init caps
    If recur Then Exit Sub
    Set thC = Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)) 'force one cell
    If thC.HasFormula Or thC.Value = "" Or IsNumeric(thC.Value) Then Exit Sub  'formula or nothing or number
    recur = True 'no change while changing
    thcD = thC.Value
    For z = 1 To Len(EndChars)
        r3 = Mid(EndChars, z, 1): r2 = r3 & " ": r1 = r2 & " "
        thcD = Replace(thcD, r3, r2) 'one space after EndChar
        thcD = Replace(thcD, r1, r2) 'get rid of multiple spaces following EndChar
        Do While InStr(1, thcD, r1) <> 0
            thcD = Replace(thcD, r1, r2)
        Loop
        'Mid(thcD, 1, 1) = UCase(Mid(thcD, 1, 1)) 'set initial char to upper
        For x = 1 To Len(thcD)
            y = InStr(x, thcD, r2)  'get location of EndChar space
            If y = 0 Then Exit For Else y = y + 2 'EndChar at char
            If y < Len(thcD) Then
                Mid(thcD, y, 1) = UCase(Mid(thcD, y, 1))
            End If
            x = y
        Next
        'thcD = Trim(thcD) 'get rid of spaces
        Cells(1, Target.Column) = thcD 'show results for testing
    Next
    recur = False
End Sub

---

anhn's code is having desired effect.
would it be better if we had this line

Code:

---

If aCell.Formula <> sText Then aCell.Formula = Trim(sText)

---

just to ensure that the user has not typed extra spaces at the end. also is this check required? can't we just have it as

Code:

---

aCell.Formula = Trim(sText)

---

dbasnett, I am not following your code :cry:

Yes, if entered text in cell ending with an EndChar followed by zero or more space(s) then the last item of the array is "" and it will be joined with a trailing space.

You can replace Sub SentenceCase() with better code below:

Code:

---

Option Explicit

Global IsUpdating As Boolean '-- (*)
'-- (*) IsUpdating is used to avoid the Sub trigger itself.

Sub SentenceCase(ByVal Target As Range)
  Const EndChars = ".?!:"
  Const Marker = "§" '-- Chr(167) : can be replaced with any unused character
  Dim aCell      As Range
  Dim sText      As String
  Dim Sentences() As String
  Dim i          As Integer
  Dim ch          As String * 1
 
  If IsUpdating Then Exit Sub '-- (*)
  For Each aCell In Target.Cells
      sText = aCell.Formula
      '-- Update only non-blank cell without formula
      If Len(sText) > 0 And Left(sText, 1) <> "=" Then
        For i = 1 To Len(EndChars)
            ch = Mid(EndChars, i, 1)
            sText = Replace(sText, ch, ch & Marker) '-- add Marker to any ending character
        Next
        Sentences = Split(sText, Marker) '-- split by Marker
        '-- Trim and Capitalize first letter of each sentence
        For i = 0 To UBound(Sentences)
            Sentences(i) = WorksheetFunction.Trim(Sentences(i))
            If Len(Sentences(i)) > 0 Then
              Sentences(i) = UCase(Left(Sentences(i), 1)) & Mid(Sentences(i), 2)
            End If
        Next
        sText = RTrim(Join(Sentences, " ")) '-- re-join with spaces
        If StrComp(aCell.Formula, sText, vbBinaryCompare) <> 0 Then
            IsUpdating = True    '-- (*)
            aCell.Formula = sText
            IsUpdating = False    '-- (*)
        End If
      End If
  Next
End Sub

---

My test data
and then...a loud bang!
one sentence.
another sentence.
one sentence.another sentence.
leading spaces.
leading spaces.one sentence.another sentence.
1. item 1
2.item2
date 11/12/2007 November 12, 2007
embedded numbers 1,213.45 123. 45
embedded numbers. a1,213.45 123. 45
embedded numbers. a.1,213.45 123. 45

My results
And then... A loud bang!
One sentence.
Another sentence.
One sentence. Another sentence.
Leading spaces.
Leading spaces. One sentence. Another sentence.
1. Item 1
2. Item2
Date 11/12/2007 November 12, 2007
Embedded numbers 1,213.45 123. 45
Embedded numbers. A1,213.45 123. 45
Embedded numbers. A.1,213.45 123. 45

note: In My test data there are leading spaces when composing the message, just not when posted.

Code:

---

Option Explicit
Option Base 1
'When a user moves from a column (say col A) in excel after typing something,
'we need to ensure that
'  any character following a EndChars should be capitalised
'  and the spacing between the EndChars and the character should be just 1 space
'
Dim thTar As Range, thcD As String, x As Integer
Dim recur As Boolean 'for recursive call protection
Dim Tcell As Range
Const EndChars = ".?!:"
'sample data.  the quick brown fox did something.  .... and what of numbers.  123.987
'Options
Dim maxC As Integer 'max number of cells to operate on
Dim ctMAX As Integer
Dim ldSPC As Boolean 'remove leading space(s)
Dim trlSPC As Boolean 'remove trailing space(s)
Dim iFrst As Boolean 'capitalize first char in cell
Dim aiCaps As Boolean 'auto sentence cap
Private Sub Worksheet_Activate()
    'this code in Worksheet_Activate for example
    aiCaps = False
    Application.AutoCorrect.CorrectSentenceCap = aiCaps
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If recur Then Exit Sub  'no change while changing
    recur = True
    ctMAX = 0
    'set the options
    ldSPC = True: trlSPC = True: iFrst = True
    maxC = 10000
    Set thTar = Target
    For Each Tcell In thTar 'in case more than one cell is selected
        Tcell = InitCaps(Range(Cells(Tcell.Row, Tcell.Column), Cells(Tcell.Row, Tcell.Column)))
        ctMAX = ctMAX + 1
        Application.StatusBar = Tcell.Address & " " & ctMAX
        If ctMAX >= maxC Then Exit For
    Next
    recur = False
    Application.StatusBar = False
End Sub
    Private Function InitCaps(ThC As Range) As String
    'states ST8
    '0-normal
    '1-found EndChars
    '2-initial space following endchar
    Dim ST8 As Integer, isEC As Boolean, crntC As String, numC As Boolean
    If ThC.HasFormula Or Trim(ThC.Value) = "" Or IsNumeric(ThC.Value) Then Exit Function 'formula or nothing or number
   
    ReDim Schr(Len(ThC.Value)) As String
    thcD = ThC.Value
    For x = 1 To Len(thcD)
        Schr(x) = Mid(thcD, x, 1)
        If Len(Schr(x)) = 1 Then Debug.Print Schr(x)
    Next
    thcD = "": ST8 = 0
    For x = 1 To UBound(Schr)
        crntC = Schr(x): If IsNumeric(crntC) Then numC = True Else numC = False
        If InStr(1, EndChars, crntC) = 0 Then isEC = False Else isEC = True
        If isEC Then 'current character in EndChars
        'yes
            Select Case ST8
                Case 0 'found EndChars, str char,chg ST8
                    thcD = thcD & crntC
                    ST8 = 1
                Case Else 'runs of EndChars
                    thcD = thcD & crntC
            End Select
        Else
        'no
            Select Case ST8
                Case 0
                    thcD = thcD & crntC 'store the character
                Case 1 'preceding char(s) was EndChars
                    If Not numC Then thcD = thcD & " " 'store space if not number
                    If crntC <> " " Then 'current character space
                        thcD = thcD & UCase(crntC) 'no - store it
                        ST8 = 0 'normal state
                    Else
                        ST8 = 2 'watch for non-space
                    End If
                Case 2
                    If crntC <> " " Then 'space
                        thcD = thcD & UCase(crntC) 'no-store it
                        ST8 = 0 'normal state
                    End If
            End Select
        End If
    Next
    If ldSPC Then thcD = LTrim(thcD) 'get rid of leading spaces
    If trlSPC Then thcD = RTrim(thcD) 'get rid of trailing spaces
    If iFrst Then Mid(thcD, 1, 1) = UCase(Mid(thcD, 1, 1)) 'set initial char to upper
    InitCaps = thcD
End Function

---