Multiple Spelling Replace Lists - Called to One Document

[sand60]

Hi,

to all the good people - greetings to all again.:)

I am trying to see if what I am trying to do is possible at all.

In my document I have different paragraphs that have different find and replace operations.

I am trying to make a case conditional statement.

I have put together a breif outline. the code does not work as i may be wrong in my thinking.
I have started with the basic - structure



Sub MultipleSpellingReplaceTableLists()


Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim oTextFind As Range
Dim oReplacementText As Range
Dim i As Long
Dim sFname As String


Dim oPar As Paragraph
For Each oPar In ActiveDocument.Range.Paragraphs
Select Case oPar.Range.Words(1)

Case Is = "List1"

sFname = "C:\SpellingList1.docx"
Set oDoc = ActiveDocument
Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
Set oTable = oChanges.Tables(1)

With oPar.Find

.MatchWildcards = True
.Text = oTextFind.Text
.Replacement.Text = oReplacementText.Text
.Forward = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next i


Case Is = "List2":

sFname = "C:\SpellingList2.docx"
Set oDoc = ActiveDocument
Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
Set oTable = oChanges.Tables(1)

With oPar.Find

.MatchWildcards = True
.Text = oTextFind.Text
.Replacement.Text = oReplacementText.Text
.Forward = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next i

Case Else:

End Select
Next


End Sub



Column 1 - find text
Column 2 - Replace text
The variable i need to set

The logic may be completely wrong -

If any one can assist me I would be grateful. I am not good with arrays - so I am not sure if I was meant to use that instead to hold the file name some how, or if i was meant to do something else such as do an IF ELSE statememt

thank you very much for looking at this if any one can

Sand

[gmaxey]

It would help if you took the time to explain what it is that you are actually trying to do.

I guessed:


Sub MultipleSpellingReplaceTableLists()
Dim oDoc As Document
Dim lngIndex As Long
Dim arrList1() As String
Dim arrList2() As String
Dim oPar As Paragraph, oRng As Range

Set oDoc = Documents.Open(FileName:="D:\List1.docm", Visible:=False)
For lngIndex = 0 To oDoc.Tables(1).Rows.Count - 2
ReDim Preserve arrList1(1, lngIndex)
arrList1(0, lngIndex) = Left(oDoc.Tables(1).Cell(lngIndex + 2, 1).Range.Text, Len(oDoc.Tables(1).Cell(lngIndex + 2, 1).Range.Text) - 2)
arrList1(1, lngIndex) = Left(oDoc.Tables(1).Cell(lngIndex + 2, 2).Range.Text, Len(oDoc.Tables(1).Cell(lngIndex + 2, 2).Range.Text) - 2)
Next lngIndex
oDoc.Close wdDoNotSaveChanges
'Repeat similar for arrList2
Set oDoc = ActiveDocument
For Each oPar In ActiveDocument.Range.Paragraphs
Select Case Trim(oPar.Range.Words(1))
Case Is = "List1"
For lngIndex = 0 To UBound(arrList1, 2)
Set oRng = oPar.Range
With oRng.Find
.MatchWildcards = True
.Text = arrList1(0, lngIndex)
.Replacement.Text = arrList1(1, lngIndex)
.Forward = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next lngIndex
Case Is = "List2"
'Repeat similiar above.
End Select
Next oPar
End Sub

[sand60]

Hi Greg,

hope you are doing great!

thank you very much for helping.:)

I have documents with lots of acronyms and syntax grammar replacement code words, different codes for different paragraphs or ranges as you call them.

I was trying to stream line the spelling replacements but then i have 3 different spelling lists to run.

Thank you very much for this

my eyes did bug out when i saw this:

arrList1(0, lngIndex) = Left(oDoc.Tables(1).Cell(lngIndex + 2, 1).Range.Text, Len(oDoc.Tables(1).Cell(lngIndex + 2, 1).Range.Text) - 2) :omg:

that is one long piece of code formulae, you formulated there, done like a pro

You have given me some really good ideas, i have been working on the lists that you helped me with very kindly.

If i may bother you for some intel - later i will post a follow up on previous list thread.
The loop or range i assume has gone off the rails - I have been trying to fix it for days

But thank you ever so much and I hope your evening is going great
Sand

[gmaxey]

Sand

That code wasn't intended to impress or boggle the senses. Intended to show that you don't have to declare variable for everything, but if you do then use the ones you declare. Also wanted you to see how to load the two arrays up front so you are not repeating the same process with each paragraph. Though I still have no clear idea what it is that you are really trying to do.

[sand60]

hi Greg,

this is what I ended up with - it works






Sub MultipleSpellingReplaceTableLists()

'Greg Maxey


Dim oDoc As Document
Dim lngIndex As Long
Dim arrList1() As String
Dim arrList2() As String
Dim oPar As Paragraph, oRng As Range

Set oDoc = Documents.Open(FileName:="C:\SpellingList1.docx", Visible:=False)
For lngIndex = 0 To oDoc.Tables(1).Rows.Count - 2
ReDim Preserve arrList1(1, lngIndex)
arrList1(0, lngIndex) = Left(oDoc.Tables(1).Cell(lngIndex + 2, 1).Range.Text, Len(oDoc.Tables(1).Cell(lngIndex + 2, 1).Range.Text) - 2)
arrList1(1, lngIndex) = Left(oDoc.Tables(1).Cell(lngIndex + 2, 2).Range.Text, Len(oDoc.Tables(1).Cell(lngIndex + 2, 2).Range.Text) - 2)
Next lngIndex
oDoc.Close wdDoNotSaveChanges

'Repeat similar for arrList2

Set oDoc = Documents.Open(FileName:="C:AcronymList2.docx", Visible:=False)
For lngIndex = 0 To oDoc.Tables(1).Rows.Count - 2
ReDim Preserve arrList2(1, lngIndex)
arrList2(0, lngIndex) = Left(oDoc.Tables(1).Cell(lngIndex + 2, 1).Range.Text, Len(oDoc.Tables(1).Cell(lngIndex + 2, 1).Range.Text) - 2)
arrList2(1, lngIndex) = Left(oDoc.Tables(1).Cell(lngIndex + 2, 2).Range.Text, Len(oDoc.Tables(1).Cell(lngIndex + 2, 2).Range.Text) - 2)
Next lngIndex
oDoc.Close wdDoNotSaveChanges


Set oDoc = ActiveDocument
For Each oPar In ActiveDocument.Range.Paragraphs
Select Case Trim(oPar.Range.Words(1))
Case Is = "List1"
For lngIndex = 0 To UBound(arrList1, 2)
Set oRng = oPar.Range
With oRng.Find
.MatchWildcards = True
.Text = arrList1(0, lngIndex)
.Replacement.Text = arrList1(1, lngIndex)
.Forward = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next lngIndex




Case Is = "List2"
For lngIndex = 0 To UBound(arrList2, 2)
Set oRng = oPar.Range
With oRng.Find
.MatchWildcards = True
.Text = arrList2(0, lngIndex)
.Replacement.Text = arrList2(1, lngIndex)
.Forward = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next lngIndex



End Select
Next oPar


End Sub



If i wanted to replace a set of keywords in a specific paragraph, all i have to do is put List1 and it will only replace in that paragraph - the words from list 1. :)

Sand

[gmaxey]

There you go.

As you have probably realized, when you want to create an array from a table you need to strip off the end of cell mark from the cell content. That mark while appearing as one character is made up of two and has a text length = 2.

While I don't always practice what I preach, as you learn to do new things it is a good idea to "compartmentalize" those things for reuse in other projects. So now anytime you want to create an array from a table you can just use your compartmentalized functions for doing that:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oDoc As Document
Dim arrList1() As String
'Document containing the table to convert to an array.
Set oDoc = Documents.Open(FileName:="C:\SpellingList1.docx", Visible:=False)
arrList1 = fcnTableToArray(oDoc.Tables(1))
oDoc.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub
Function fcnTableToArray(oTbl As Word.Table, Optional bHeadingRow As Boolean = True) As String()
'Returns as two dimensional array containing the contents of a Word table
Dim lngIndex As Long, lngOffset As Long
Dim arrTemp() As String
lngOffset = IIf(bHeadingRow, 2, 1)
For lngIndex = 0 To oTbl.Rows.Count - lngOffset
ReDim Preserve arrTemp(1, lngIndex)
arrTemp(0, lngIndex) = fcnGetCellText(oTbl.Cell(lngIndex + lngOffset, 1))
arrTemp(1, lngIndex) = fcnGetCellText(oTbl.Cell(lngIndex + lngOffset, 2))
Next lngIndex
fcnTableToArray = arrTemp
End Function
Function fcnGetCellText(ByRef oCell As Word.Cell) As String
'Replace the end of cell marker with a null string.
fcnGetCellText = Replace(oCell.Range.Text, ChrW(13) & ChrW(7), vbNullString)
lbl_Exit:
Exit Function
End Function

[sand60]

Greg,

thank you very much.

I didn't even know what a macro was a month ago.

But these macros are very helpful not having to do it manually the search and replace and to have all my acronym lists organized and easy to update as well, such a bonus.

Where have macros been all my life.

I will play about with including the functions into my code.

Good weekend to you and all the forum

sand

[gmaxey]

The function I posted earlier wasn't that well thought out as it was limited to a two column table. Something like this would be better:


Option Explicit
'A basic Word macro coded by Greg Maxey
Sub DemoTableToArray()
Dim oDoc As Document
Dim arrData() As String
Dim lngX As Long, lngY As Long
'Document containing the table to convert to an array.
Set oDoc = ActiveDocument 'Documents.Open(FileName:="C:\Data.docx", Visible:=False)
If oDoc.Tables(1).Uniform Then
arrData = fcnTableToArray(oDoc.Tables(1))
'To process data as it appears left to right then down the table:
For lngY = 0 To UBound(arrData, 2)
For lngX = 0 To UBound(arrData, 1)
Debug.Print arrData(lngX, lngY)
Next
Next
'To process data as it appears down the table then left to right:
For lngX = 0 To UBound(arrData, 1)
For lngY = 0 To UBound(arrData, 2)
Debug.Print arrData(lngX, lngY)
Next
Next
Else
MsgBox "Table is not uniform" & vbCr + vbCr _
& "To create an array the table may not contain merged or split cells", _
vbInformation + vbOKOnly, "NON-UNIFORM TABLE"
End If
'oDoc.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub
Function fcnTableToArray(oTbl As Word.Table, Optional bHeadingRow As Boolean = True) As String()
'Returns as two dimensional array containing the contents of a Word table
Dim lngIndex As Long, lngOffset As Long, lngCols As Long, lngCol As Long
Dim arrTemp() As String
lngOffset = IIf(bHeadingRow, 2, 1)
lngCols = oTbl.Columns.Count
For lngIndex = 0 To oTbl.Rows.Count - lngOffset
ReDim Preserve arrTemp(lngCols - 1, lngIndex)
For lngCol = 1 To lngCols
arrTemp(lngCol - 1, lngIndex) = fcnGetCellText(oTbl.Cell(lngIndex + lngOffset, lngCol))
Next lngCol
Next lngIndex
fcnTableToArray = arrTemp
lbl_Exit:
Exit Function
End Function
Function fcnGetCellText(ByRef oCell As Word.Cell) As String
'Replace the end of cell marker with a null string.
fcnGetCellText = Replace(oCell.Range.Text, ChrW(13) & ChrW(7), vbNullString)
lbl_Exit:
Exit Function
End Function

[sand60]

Greg,

thank you again this is a treat - I can grow my table collection now :grinhalo:

Its very very generous of you to code this so every one can benefit.

I have seen many of your other posts - over generous to a T

its nice that some one can help us newbies - clue less is an understatement.

I can't even code my own few lines but you have a gift.

Great day to you

Sand