Learn when you want, where you want with convenient online training courses. Sign up now!
Experts Exchange Solution brought to you by
"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.
Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!
Private bErrorsFound As Boolean
Public Sub spellcheck()
Dim rngSpelCheck As Range
Set rngSpelCheck = ActiveSheet.Range("A1:L50")
If Not bErrorsFound Then
MsgBox "No spelling errors found"
Sub ExtractTextAndSpellcheck(ByRef objRange As Range)
Dim c As Integer
Dim rng As Range
Dim shp As Shape
Dim shpInGroup As Shape
Dim lngIndex As Long
Dim strWords() As String
Dim strText As String
Set rng = ActiveCell
On Error Resume Next
For Each shp In ActiveSheet.Shapes
If Not (Intersect(shp.TopLeftCell, objRange) Is Nothing) Or Not Intersect(shp.BottomRightCell, objRange) Is Nothing Then
If shp.Type = msoGroup Then ' shp.Ungroup
For lngIndex = 1 To shp.GroupItems.Count
Set shpInGroup = shp.GroupItems(lngIndex)
shpInGroup.TextFrame.Characters.Text = SpellWord(shpInGroup.TextFrame.Characters.Text)
If shp.TextFrame.Characters.Text <> "" Then
shp.TextFrame.Characters.Text = SpellWord(shp.TextFrame.Characters.Text)
Private Function SpellWord(strWord As String) As String
' Word must be installed for this to work
' objDoc.Checkgrammar ' use this to check grammar
Dim objWord As Object
Dim objDoc As Object
Dim strResult As String
Dim bWordAlreadyOpen As Boolean
Const QUOTE = """"
If IsAppRunning("Word.Application") = True Then
Set objWord = GetObject(, "Word.Application")
bWordAlreadyOpen = True
Set objWord = CreateObject("Word.Application")
Select Case objWord.Version
'Office 2000 and later
Case "9.0", "10.0", "11.0", "14.0"
Set objDoc = objWord.Documents.Add(, , 1, True)
Set objDoc = objWord.Documents.Add
MsgBox "Sorry but your version of Word seems to be " & QUOTE & objWord.Version _
& QUOTE & " and that version is not currently supported.", vbOKOnly + vbExclamation, "Spelling Checker"
objDoc.Content = strWord
objWord.Visible = False
strResult = Left(objDoc.Content, Len(objDoc.Content) - 1)
' Reformat carriage returns
strResult = Replace(strResult, Chr(10), Chr(13) & Chr(10))
If strWord <> strResult Then
bErrorsFound = True
Set objDoc = Nothing
If Not bWordAlreadyOpen Then
Set objWord = Nothing
' Replace the text with the corrected text. It's important that
' this be done after the "Clean Up" because otherwise there are problems
' with the screen not repainting
SpellWord = strResult
Select Case Err.Number
MsgBox "Word must be installed in order for this code to work", vbCritical + vbOKOnly, "Spelling Checker"
Function IsAppRunning(ByVal sAppName) As Boolean
Dim oApp As Object
On Error Resume Next
Set oApp = GetObject(, sAppName)
If Not oApp Is Nothing Then
Set oApp = Nothing
IsAppRunning = True
Open in new window
Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.
From novice to tech pro — start learning today.
Premium members can enroll in this course at no extra cost.