VBA Snippets

Char_InsertCopyright

Public Sub Char_InsertCopyright()
Const sPROCNAME As String = "Char_InsertCopyright"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=169, Unicode:=True, Bias:=0
   Selection.MoveLeft wdCharacter, 1, True
   Selection.Font.Superscript = True
   Selection.MoveRight wdCharacter, 1, False
   Selection.Font.Superscript = False
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertCubed

Public Sub Char_InsertCubed()
Const sPROCNAME As String = "Char_InsertCubed"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=179, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertDegrees

Public Sub Char_InsertDegrees()
Const sPROCNAME As String = "Char_InsertDegrees"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=176, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertEmDash

Public Sub Char_InsertEmDash()
Const sPROCNAME As String = "Char_InsertEmDash"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=8212, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertEnDash

Public Sub Char_InsertEnDash()
Const sPROCNAME As String = "Char_InsertEnDash"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=8211, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreaterThanOrEqualTo

Public Sub Char_InsertGreaterThanOrEqualTo()
Const sPROCNAME As String = "Char_InsertGreaterThanOrEqualTo"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=8805, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekAlpha

Public Sub Char_InsertGreekAlpha()
Const sPROCNAME As String = "Char_InsertGreekAlpha"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=945, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekBeta

Public Sub Char_InsertGreekBeta()
Const sPROCNAME As String = "Char_InsertGreekBeta"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=946, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekDelta

Public Sub Char_InsertGreekDelta()
Const sPROCNAME As String = "Char_InsertGreekDelta"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=948, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekEpsilon

Public Sub Char_InsertGreekEpsilon()
Const sPROCNAME As String = "Char_InsertGreekEpsilon"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=949, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekGamma

Public Sub Char_InsertGreekGamma()
Const sPROCNAME As String = "Char_InsertGreekGamma"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=947, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekKappa

Public Sub Char_InsertGreekKappa()
Const sPROCNAME As String = "Char_InsertGreekKappa"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=954, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekLambda

Public Sub Char_InsertGreekLambda()
Const sPROCNAME As String = "Char_InsertGreekLambda"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=955, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekMu

Public Sub Char_InsertGreekMu()
Const sPROCNAME As String = "Char_InsertGreekMu"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=956, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekOmega

Public Sub Char_InsertGreekOmega()
Const sPROCNAME As String = "Char_InsertGreekOmega"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=937, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekPi

Public Sub Char_InsertGreekPi()
Const sPROCNAME As String = "Char_InsertGreekPi"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=960, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekSigma

Public Sub Char_InsertGreekSigma()
Const sPROCNAME As String = "Char_InsertGreekSigma"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=963, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertGreekTau

Public Sub Char_InsertGreekTau()
Const sPROCNAME As String = "Char_InsertGreekTau"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol Font:=Selection.Range.Font.Name, CharacterNumber:=964, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertLessThanOrEqualTo

Public Sub Char_InsertLessThanOrEqualTo()
Const sPROCNAME As String = "Char_InsertLessThanOrEqualTo"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=8804, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertMultiplication

Public Sub Char_InsertMultiplication()
Const sPROCNAME As String = "Char_InsertMultiplication"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=215, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertNonBreakingHyphen

Public Sub Char_InsertNonBreakingHyphen()
Const sPROCNAME As String = "Char_InsertNonBreakingHyphen"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=30, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertNonBreakingSpace

Public Sub Char_InsertNonBreakingSpace()
Const sPROCNAME As String = "Char_InsertNonBreakingSpace"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=160, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertOneHalf

Public Sub Char_InsertOneHalf()
Const sPROCNAME As String = "Char_InsertOneHalf"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=189, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertOneQuarter

Public Sub Char_InsertOneQuarter()
Const sPROCNAME As String = "Char_InsertOneQuarter"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=188, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertPlusMinus

Public Sub Char_InsertPlusMinus()
Const sPROCNAME As String = "Char_InsertPlusMinus"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=177, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertRegistered

Public Sub Char_InsertRegistered()
Const sPROCNAME As String = "Char_InsertRegistered"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=174, Unicode:=True, Bias:=0
   Selection.MoveLeft wdCharacter, 1, True
   Selection.Font.Superscript = True
   Selection.MoveRight wdCharacter, 1, False
   Selection.Font.Superscript = False
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertSquared

Public Sub Char_InsertSquared()
Const sPROCNAME As String = "Char_InsertSquared"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=178, Unicode:=True
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertThreeQuarters

Public Sub Char_InsertThreeQuarters()
Const sPROCNAME As String = "Char_InsertThreeQuarters"
   On Error GoTo ErrorHandler
   Selection.InsertSymbol CharacterNumber:=190, Unicode:=True, Bias:=0
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Char_InsertTrademark

Public Sub Char_InsertTrademark()
Const sPROCNAME As String = "Char_InsertTrademark"
   On Error GoTo ErrorHandler
   Selection.TypeText "TM"
   Selection.MoveLeft wdCharacter, 2, True
   Selection.Font.Superscript = True
   Selection.MoveRight wdCharacter, 2
   Selection.MoveRight wdCharacter, 1, False
   Selection.Font.Superscript = False
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Selection_Bold

Bolds the selected cells.

Public Function Sel_Bold(Optional bBold As Boolean = True) As Boolean
Const sPROCNAME As String = "Sel_Bold"
   On Error GoTo AnError
   Selection.Font.Bold = bBold
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "bold / unbold the highlighted cells")
End Function

Selection_BoldIsIt

Determines if any of the selected cells contain bold text.

Public Function Sel_BoldIsIt() As Boolean
Const sPROCNAME As String = "Sel_BoldIsIt"
   On Error GoTo AnError
   If Selection.Font.Bold = True Then Sel_BoldIsIt = True
   If Selection.Font.Bold = False Then Sel_BoldIsIt = False
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if any of the highlighted cells are bold or unbold")
End Function

Selection_Format

Applies formatting to the current selection.

Public Sub Sel_Format()
Const sPROCNAME As String = "Sel_Format"
   On Error GoTo AnError

'italics, underline, font name, font size

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "apply any formatting to the current selection")
End Sub

Selection_HasAnyShapes

Public Function Sel_HasAnyShapes() As Boolean
   On Error GoTo AnError
   If Application.Selection.Range.ShapeRange.Count > 0 Then
      Sel_HasAnyShapes = True
   End If
AnError:
   Sel_HasAnyShapes = False
End Function

Selection_PasteSpecial

Public Function Sel_PasteSpecial(ByVal enPasteDataType As WdPasteDataType, _
                                 ByVal bLink As Boolean, _
                        Optional ByVal bInformUser As Boolean = True) _
                                 As Boolean
   
   On Error GoTo AnError
      
   Selection.Range.PasteSpecial Placement:=wdInLine, DataType:=enPasteDataType, Link:=bLink
   Sel_PasteSpecial = True
   Exit Function
   
AnError:
   If bInformUser = True Then
      Call MsgBox("There is nothing on the Clipboard to paste.", vbCritical)
   End If
   Sel_PasteSpecial = False
End Function

Selection_RemoveLastChar

Removes the last character if it matching a given string from all the cells currently highlighted.

Public Sub Sel_RemoveLastChar(Optional sChar As String = "%")
Const sPROCNAME As String = "Sel_RemoveLastChar"
Dim scontents As String, clcell As cell
   On Error GoTo AnError
   For Each clcell In Selection.Cells
      scontents = Left$(clcell.Range.Text, Len(clcell.Range.Text) - 2)
      If Len(scontents) > 0 Then
         If Right$(scontents, 1) = sChar Then _
            clcell.Range.Text = Left$(scontents, Len(scontents) - 1) & vbCrLf
      End If
   Next clcell
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove the last character if it matches """ & sChar & """" & _
        " from all the cells currently highlighted")
End Sub

Selection_RemovePreceedingChar

Removes all the given characters that preceed any text in the cells of the current selection.

Public Sub Sel_RemovePreceedingChar(Optional sChar As String = " ")
Const sPROCNAME As String = "Sel_RemoveLastChar"
Dim scontents$, clcell As cell
   On Error GoTo AnError
   For Each clcell In Selection.Cells
      scontents = Left$(clcell.Range.Text, Len(clcell.Range.Text) - 2)
      Do While Left$(scontents, 1) = sChar
         scontents = Right$(scontents, Len(scontents) - 1)
      Loop
      clcell.Range.Text = scontents & Right$(clcell.Range.Text, 1)
   Next clcell
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove all the characters that preceed a given string " & _
        "from all the cells currently highlighted")
End Sub

Selection_TitleCase

Public Sub Selection_TitleCase()
Const sPROCNAME As String = "Selection_TitleCase"
Dim lclist As String
Dim wrd As Integer
Dim sTest As String
   On Error GoTo ErrorHandler
   ' list of lowercase words, surrounded by spaces
   lclist = " of the by to this is from a "
   Selection.Range.Case = wdTitleWord
   For wrd = 2 To Selection.Range.Words.Count
       sTest = Trim(Selection.Range.Words(wrd))
       sTest = " " & LCase(sTest) & " "
       If InStr(lclist, sTest) Then
           Selection.Range.Words(wrd).Case = wdLowerCase
       End If
   Next wrd
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Selection_UnderlinedIsIt

Determines if any of the highlighted cells are underlined.

Public Function Sel_UnderlinedIsIt() As Boolean
Const sPROCNAME As String = "Sel_UnderlinedIsIt"
   On Error GoTo AnError
   Sel_AnyUnderlined = _
     (Selection.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle)
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if any of the highlighted cells are underlined")
End Function

Text_FindReplace

Performs a find and replace on the current selection in the active table.

Public Sub Text_FindReplace(sFindText As String, _
                            sReplaceText As String)
   On Error GoTo AnError
   
   With Selection.Find
     .Replacement.ClearFormatting
     .Text = sFindText
     .Replacement.Text = sReplaceText
     .Execute Replace:=wdReplaceAll
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Text_FindReplace", msMODULENAME, 1, _
        "")
End Sub

Text_Format

Formats the text that is currently selected.

Public Sub Text_Format(sFontName As String, _
                       sngFontSize As Single, _
                       lFontColour As Long, _
                       bBold As Boolean)
   On Error GoTo AnError
   Selection.style = ActiveDocument.Styles("Normal")
   With Selection.Font
      .Name = Return_FontName(sFontName)
      .Size = sngFontSize
      .Italic = False
      .Bold = bBold
      .ColorIndex = lFontColour
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Text_Format", msMODULENAME, 1, _
        "")
End Sub

Text_MoveAbove

Moves a particular number of lines above the current selection.

Public Sub Text_MoveAbove(iNoOfLines As Integer)
   On Error GoTo AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Text_MoveAbove", msMODULENAME, 1, _
        "")
End Sub

Text_MoveDown

Moves a particular number of lines below the current selection.

Public Sub Text_MoveDown(iNoOfLines As Integer)
   On Error GoTo AnError
                                                     
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Text_MoveDown", msMODULENAME, 1, _
        "")
End Sub

---

© 2025 Better Solutions Limited. All Rights Reserved. © 2025 Better Solutions Limited Top