I was looking to see if it was possible to create a macro that locates underlined words in a word document and converts them to the html tags. i tried to record a macro to do that but it just adds tags to all words. I also provide some of the code i tried to use:
Dim myWords() As String
Dim i As Long
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content
Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Application.ScreenUpdating = False
ReDim myWords(aRange.Words.Count) ' set a array as large as the
' number of words in the doc
For Each Sentence In myDoc.StoryRanges
For Each w In Sentence.Words
If w.Font.Underline <> wdUnderlineNone Then
myDoc.Sentence.Range.InsertBefore "<u>"
myDoc.Sentence.Range.InsertAfter "</u>"
End If
Well this code looks familiar!
Here's a tweak on what you've done that should add the tag around each underlined word. It's important to note, you must remove the underline property, and then add the tag. Otherwise word will treat the newly introduced tag as a new word, and repeat the process.
Sub ChangeUnderLineToHTML()
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content ' Change as needed
Dim sRanges As Variant: Set sRanges = myDoc.StoryRanges
Dim sentence As Object
Dim w As Object
For Each sentence In sRanges
For Each w In sentence.Words
If w.Font.Underline <> wdUnderlineNone Then
w.Font.Underline = wdUnderlineNone
w.Text = "<u>" & w.Text & "</u>"
End If
Next w
Next sentence
'Clean Up
Set myDoc = Nothing
Set aRange = Nothing
Set sRanges = Nothing
Set w = Nothing
Set sentence = Nothing
End Sub
Related
I am creating a word report through excel VBA. I need math equation to be written but unfortunately, the word document do not autocorrect \pi and \times. Otherwise the equation is printed. Can someone suggest me what is the way forward. Below is the code
Sub AreaSolidBolt(wrdApp As Object, wrdDoc As Object, d As Variant)
Dim objRange As Object
Dim objEq As OMath
Dim aCorrect As OMathAutoCorrectEntry
wrdApp.OMathAutoCorrect.UseOutsideOMath = True
Set objRange = wrdDoc.Range
objRange.Text = "A = \pi/4 \times d^2"
Set objRange = wrdApp.Selection.OMaths.Add(objRange)
For Each aCorrect In wrdApp.OMathAutoCorrect.Entries
With objRange
If InStr(.Text, aCorrect.Name) > 0 Then
.Text = Replace(.Text, aCorrect.Name, aCorrect.Value)
End If
End With
Next aCorrect
Set objEq = objRange.OMaths(1)
objEq.BuildUp
Set objRange = Nothing
End Sub
I have defined the objects as below in the calling function. Can you please suggest me the way forward.
Set fso = CreateObject("Scripting.FileSystemObject")
Set wrdApp = CreateObject("Word.Application")
If Not fso.FileExists(wrdFileName) Then
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = False
With wrdDoc
.SaveAs FileName:=wrdFileName
End With
Else
Set wrdDoc = wrdApp.Documents.Open(wrdFileName)
wrdApp.Visible = False
wrdDoc.Content.InsertAfter vbLf
End If
If the AutoCorrect isn't recognizing something you need to use, then you can write in the corresponding (unicode) character code as part of the equation, using ChrW(). PI is 960, for example.
It's not clear what you consider a "times" character, whether an "x" an "*" or something else. I note that most Math equations don't actually use a character for multiplication, which may be why AutoCorrect isn't picking that up. But you can certainly just type those in?
For example:
objRange.Text = "A = " & ChrW(960) & "/4 * d^2"
I have found the answer myself. The was slightly modified. The error was with the placement of the code line
Set objRange = wrdApp.Selection.OMaths.Add(objRange)
Below is the modified code.
Sub AreaSolidBolt(wrdApp As Object, wrdDoc As Object, d As Variant)
Dim objRange As Object
Dim objEq As OMath
Dim aCorrect As OMathAutoCorrectEntry
wrdApp.OMathAutoCorrect.UseOutsideOMath = True
Set objRange = wrdDoc.Range
objRange.Text = "A = \pi/4 \times d^2"
For Each aCorrect In wrdApp.OMathAutoCorrect.Entries
With objRange
If InStr(.Text, aCorrect.Name) > 0 Then
.Text = Replace(.Text, aCorrect.Name, aCorrect.Value)
End If
End With
Next aCorrect
Set objRange = wrdApp.Selection.OMaths.Add(objRange)
Set objEq = objRange.OMaths(1)
objEq.BuildUp
Set objRange = Nothing
End Sub
I am making a VBA machine that takes a Word document and searches it for terms in an Excel file, then copies each sentence with the term and pastes it in the Excel sheet. I have kind of cobbled together two different pieces of code that search a Word document for a list of words from another Word document, and one that copies every sentence that uses a given word. Here is my code:
Sub thesearchmacro()
Dim excelfile As Object
Dim excelsheet As Object
Dim worddoc As Document
Dim searchcell As Range
Dim destcol As Integer
Dim destrow As Integer
Dim searchterms As Range
Dim documentrange As Range
Set documentrange = ActiveDocument.Range
Set excelfile = CreateObject("Excel.Application")
Set excelsheet = excelfile.workbooks.Open("U:\filepath\searchmachine.xlsm")
Set searchterms = excelsheet.Worksheets("Data").Range("B2:GX2")
destcol = 2
For Each searchcell In searchterms.Cells
destrow = 3
With documentrange.Find
Do
.Text = searchcell
documentrange.Expand unit:=wdSentence
documentrange.Copy
documentrange.Collapse wdCollapseEnd
excelsheet.Cells(destrow, destcol).Paste
destrow = destrow + 1
Loop While .Found
destcol = destcol + 1
End With
Next
End Sub
Whenever I run this:
Set searchterms = excelsheet.Worksheets("Data").Range("B2:GX2")
comes back with a type mismatch error.
*edit: missed a copy
added findwindow's suggestion
This is what worked in the end. If you are trying to replicate it feel free to ask me anything.
Sub thesearchmacro()
Dim excelfile As Object
Dim excelsheet As Object
Dim worddoc As Document
Dim searchcell As Object
Dim destcol As Integer
Dim destrow As Integer
Dim destcell as Object
Dim searchterms As Object
Dim documentrange As Range
Set documentrange = ActiveDocument.Range
Set excelfile = CreateObject("Excel.Application")
Set excelsheet = excelfile.workbooks.Open("U:\filepath\searchmachine.xlsm")
Set searchterms = excelsheet.Worksheets("Data").Range("B2:GX2")
destcol = 2
For Each searchcell In searchterms.Cells
destrow = 3
With documentrange.Find
Do
.Text = searchcell
.execute
If .Found Then
documentrange.Expand unit:=wdSentence
excelsheet.Sheets("Data").Cells(destrow, destcol) = documentrange
documentrange.Collapse wdCollapseEnd
destrow = destrow + 1
Loop While .Found
destcol = destcol + 1
End With
Next
End Sub
Word.Range and Excel.Range are different types.
If you are happy to add a reference to Excel to your project, do that and replace all Ranges with either Word.Range or Excel.Range as appropriate.
Otherwise declare all Excel types as Objects.
I want to create a word document using Excel VBA, and add text with various font styles and sizes. Here is my code:
Sub CreateNewWordDoc()
Dim wrdDoc As Word.Document
Dim wrdApp As Word.Application
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
Dim charStart As Long
Dim charEnd As Long
With wrdDoc
For i = 1 To 3
charStart = wrdApp.Selection.Start
.Content.InsertAfter (" some text")
charEnd = wrdApp.Selection.End
If i = 1 Then
'set the text range (charStart,charEnd) to e.g. Arial, 8pt
Else
If i = 2 Then
'set the text range (charStart,charEnd) to e.g. Calibri, 10pt
Else
'set the text range (charStart,charEnd) to e.g. Verdana, 12pt
End If
End If
Next i
.Content.InsertParagraphAfter
.SaveAs ("testword.docx")
.Close ' close the document
End With
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
How can I define font style and size on-the-fly in the if-else statement above?
Would something like this fit the bill?
Sub CreateNewWordDoc()
Dim doc As Word.Document
Dim toAdd As String
Dim lengthAdded As Long
Dim selStart As Long
Set doc = ActiveDocument
toAdd = "Hello World" ' What to add?
lengthAdded = Len(toAdd) ' For later!
selStart = Selection.Start ' Where to add the text?
doc.Range(selStart).InsertAfter (toAdd)
With doc.Range(selStart, selStart + lengthAdded)
' Here's where the font stuff happens
.Font.Name = "Arial"
.Font.Size = 15
End With
End Sub
Note that I've got rid of most of the code which isn't directly pertinent to the question. Hopefully you can extrapolate from my code to yours!
My project is to change words/phrases in the whole Bible, and I have the Word doc with the Bible in it, and separately, I have an Excel file with Column A oldwords that need to be found by the macro, Column B newwords that will replace the old ones.
I was gracefully provided with this macro, which works well in MS Word 2010, but as you can see, it is setup to use Data arrays. It even says, "'Note: Data arrays are used in this example. In practice the data could come from a Word table, Excel worksheet or other data source.". So, I need to adapt it so that it gets the data from my Excel file where I have all the words/phrases that need to be changed.
There are 2 class modules and 1 standard module. But at the end of this post, I'm also including yet more code that should do what I want (get data from an Excel file) but it needs to be adapted to work in my macro. The problem is, I don't know how to adapt it. In other words: I don't know what needs to be replaced in the module/s in order to make it work.
Also, I believe my Excel file needs to be simple. Column A Old wordorphrase // Column B New wordorphrase. Would that work fine just like that?
Here is everything I have (separately):
First class module I was told to name it "clsTerm" and paste this code:
Option Explicit
Private English As String
Private Hebrew As String
Private FNT As String
Property Let EnglishTerm(strVal As String)
English = strVal
End Property
Property Get EnglishTerm() As String
EnglishTerm = English
End Property
Property Let HebrewTerm(strVal As String)
Hebrew = strVal
End Property
Property Get HebrewTerm() As String
HebrewTerm = Hebrew
End Property
Property Let FootnoteText(strVal As String)
FNT = strVal
End Property
Property Get FootnoteText() As String
FootnoteText = FNT
End Property
Second class module I was told to name it "clsTerms" and paste this code:
Option Explicit
Private colTerms As Collection
Private lngCount As Long
Property Get Items() As Collection
Set Items = colTerms
End Property
Property Set Items(oCol As Collection)
Set colTerms = oCol
End Property
Property Get Count() As Long
If Not colTerms Is Nothing Then
Count = colTerms.Count
Else
Count = 0
End If
End Property
Then I was told to create a standard module and name it "Anything I like" and paste this code:
Option Explicit
Dim m_oCol1 As Collection
Dim m_oCol2 As Collection
Sub ReplaceWordsAndDefineFootnotes()
Dim clsTL As clsTerms
Dim lngIndex As Long
Set clsTL = New clsTerms
Set clsTL.Items = DefinedTerms
Set m_oCol1 = New Collection
For lngIndex = 1 To clsTL.Count
'Replace each defined English word with it Hebrew equivelent.
ReplaceWords clsTL.Items(lngIndex).EnglishTerm, clsTL.Items(lngIndex).HebrewTerm
Next lngIndex
Underline_And_DefineFootnote
For lngIndex = 1 To clsTL.Count
'Replace temporary footnote text with with class defined footnote text.
FixFootnotes clsTL.Items(lngIndex).HebrewTerm, clsTL.Items(lngIndex).FootnoteText
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Function DefinedTerms() As Collection
Dim arrEng() As String
Dim arrHeb() As String
Dim lngIndex As Long
Dim oCol As Collection
Dim Term As clsTerm
'Note: Data arrays are used in this example. In practice the data could come from a Word table, Excel worksheet or other data source.
arrEng = Split("God,heaven,earth,waters,good", ",")
arrHeb = Split("Elohim,shamayim,aretz,mayim,tov", ",")
Set oCol = New Collection
'Put data in the collection.
For lngIndex = 0 To UBound(arrEng)
Set Term = New clsTerm
Term.EnglishTerm = arrEng(lngIndex)
Term.HebrewTerm = arrHeb(lngIndex)
Term.FootnoteText = arrEng(lngIndex) & ":" & arrHeb(lngIndex)
oCol.Add Term, Term.EnglishTerm
Next lngIndex
Set DefinedTerms = oCol
lbl_Exit:
Exit Function
End Function
Sub ReplaceWords(ByVal strFind As String, ByVal strReplaceWith As String)
Dim oRng As Word.Range
'Add each term processed to a collection.
m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
Set oRng = ActiveDocument.Range
'Replace each instance of the English word with its Hebrew equivalent.
With oRng.Find
.Text = strFind
.Replacement.Text = strReplaceWith
.MatchWholeWord = True
.MatchCase = False
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub
Sub Underline_And_DefineFootnote()
Dim oRng As Word.Range
Dim lngIndex As Long
Dim oWord As Word.Range
Dim strWord As String
Dim lngCounter As Long
Dim lngPages As Long
With ActiveDocument
Set oRng = .Range
lngPages = .ComputeStatistics(wdStatisticPages)
For lngIndex = 1 To lngPages
Reprocess:
Set m_oCol2 = New Collection
Set oRng = oRng.GoTo(What:=wdGoToPage, Name:=lngIndex)
Set oRng = oRng.GoTo(What:=wdGoToBookmark, Name:="\page")
lngCounter = 1
With oRng
For Each oWord In oRng.Words
'Modify the word range to strip off white space. We want only the text portion of the word range.
strWord = UCase(Trim(oWord.Text))
oWord.Collapse wdCollapseStart
oWord.MoveEnd wdCharacter, Len(strWord)
If oWord.Characters.Last = Chr(160) Then oWord.MoveEnd wdCharacter, -1
'We need to know if the text defined by the word range is a word we want to process.
'We added all of those words to a collection during the find and replace process.
'If we try to add one of those words to the collection again then it will error and we will know _
we are dealing with a word we want to process.
On Error Resume Next
m_oCol1.Add strWord, strWord
If Err.Number <> 0 Then
On Error GoTo 0
On Error Resume Next
'We only want to underline and footnote the first instance of the term on each page.
'So add the term and key to a collection.
m_oCol2.Add strWord, strWord
If Err.Number = 0 Then
'There was no error so underline the term and footnote it.
oWord.Font.Underline = 1
On Error GoTo 0
ActiveDocument.Footnotes.Add oWord, CStr(lngCounter), LCase(strWord)
lngCounter = lngCounter + 1
End If
Else
'The word wasn't a word we want to process so remove it from the collection.
m_oCol1.Remove m_oCol1.Count
End If
Next oWord
End With
'Since processing words will add footnotes, the length of the document will increase.
'I'm using this method to reenter the processing loop.
lngPages = .ComputeStatistics(wdStatisticPages)
If lngIndex < lngPages Then
lngIndex = lngIndex + 1
GoTo Reprocess
End If
Next lngIndex
End With
Set oRng = Nothing
End Sub
Sub FixFootnotes(ByVal strFind As String, ByVal strReplaceWith As String)
Dim oRng As Word.Range
m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng.Find
.Text = strFind
.Replacement.Text = strReplaceWith
.MatchWholeWord = True
.MatchCase = False 'True
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub
And finally, this is the code that I need to adapt into my macro, in order to make it get the data from the Excel file:
Sub ListFromExcel()
Dim lngIndex As Long
Dim arrWords As Variant
'Find words in column 1, Replace words in column 2
arrWords = GetListArray(You file path and name)
For lngIndex = 2 To UBound(arrWords, 1)
Debug.Print arrWords(lngIndex, 1)
Debug.Print arrWords(lngIndex, 2)
Next
End Sub
Function GetListArray(ByRef strFileName As String) As Variant
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim bAppStart As Boolean
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
bAppStart = True
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlbook = xlapp.Workbooks.Open(FileName:=strFileName)
Set xlsheet = xlbook.Worksheets(1)
GetListArray = xlsheet.Range("A1").CurrentRegion.Value
xlbook.Close
If bAppStart = True Then xlapp.Quit
Set xlapp = Nothing
Set xlbook = Nothing
Set xlsheet = Nothing
lbl_Exit:
Exit Function
End Function
Change the first sub to this
Sub ReplaceWordsAndDefineFootnotes()
Dim clsTL As clsTerms
Dim lngIndex As Long
Set clsTL = New clsTerms
clsTL.FillFromExcel
Set m_oCol1 = New Collection
For lngIndex = 1 To clsTL.Count
'Replace each defined English word with it Hebrew equivelent.
ReplaceWords clsTL.Items(lngIndex).EnglishTerm, clsTL.Items(lngIndex).HebrewTerm
Next lngIndex
Underline_And_DefineFootnote
For lngIndex = 1 To clsTL.Count
'Replace temporary footnote text with with class defined footnote text.
FixFootnotes clsTL.Items(lngIndex).HebrewTerm, clsTL.Items(lngIndex).FootnoteText
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Add this to the clsTerms class
Public Sub FillFromExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim vaWords As Variant
Dim cTerm As clsTerm
Dim i As Long
Const sFILE As String = "C:\Users\Dick\Documents\My Dropbox\Excel\wordlist.xlsx"
Const xlUP As Long = -4162
Set colTerms = New Collection
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(sFILE, , True)
With xlWb.Worksheets(1)
vaWords = .Range("A1", .Cells(.Rows.Count, 2).End(xlUP)).Value
End With
For i = LBound(vaWords, 1) To UBound(vaWords, 1)
Set cTerm = New clsTerm
cTerm.EnglishTerm = vaWords(i, 1)
cTerm.HebrewTerm = vaWords(i, 2)
cTerm.FootnoteText = vaWords(i, 1) & ":" & vaWords(i, 2)
colTerms.Add cTerm
Next i
xlWb.Close False
xlApp.Quit
End Sub
I'm working with an MS Word macro that currently calls data from an external Excel file, for a find/replace procedure in a long MS Word text. In my Excel file, Columns A has the words I want to find and Column B the words to replace with. Each change the macro performs, gets underlined and also a footnote is created on the text.
Now I need to have the macro add yet additional information about the change and also put it in the footnote. I have what I want to add, ready to go in Columns C of my Excel sheet.
More simply put: My code is already getting data from Columns A and B and putting it in the footnote. So, all I need to do now is, tell it to get the data ALSO from Column C. How do I do that?
Here's the full code:
1 standard module:
Option Explicit
Dim m_oCol1 As Collection
Dim m_oCol2 As Collection
Sub ReplaceWordsAndDefineFootnotes()
Dim clsTL As clsTerms
Dim lngIndex As Long
Set clsTL = New clsTerms
clsTL.FillFromExcel
Set m_oCol1 = New Collection
For lngIndex = 1 To clsTL.Count
'Replace each defined English word with it Hebrew equivelent.
ReplaceWords clsTL.Items(lngIndex).English, clsTL.Items(lngIndex).Hebrew
Next lngIndex
Underline_And_DefineFootnote
For lngIndex = 1 To clsTL.Count
'Replace temporary footnote text with with class defined footnote text.
FixFootnotes clsTL.Items(lngIndex).Hebrew, clsTL.Items(lngIndex).Footnote
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Function DefinedTerms() As Collection
Dim arrEng() As String
Dim arrHeb() As String
Dim lngIndex As Long
Dim oCol As Collection
Dim Term As clsTerm
'Note: Data arrays are used in this example. In practice the data could come from a Word table, Excel worksheet or other data source.
'arrEng = Split("God,heaven,earth,waters,good", ",")
'arrHeb = Split("Elohim,shamayim,aretz,mayim,tov", ",")
Set oCol = New Collection
'Put data in the collection.
For lngIndex = 0 To UBound(arrEng)
Set Term = New clsTerm
Term.English = arrEng(lngIndex)
Term.Hebrew = arrHeb(lngIndex)
Term.Footnote = arrEng(lngIndex) & ":" & arrHeb(lngIndex)
'Term.FootnoteText = varWords(lngIndex, 3) & ":" & varWords(lngIndex, 1)
oCol.Add Term, Term.English
Next lngIndex
Set DefinedTerms = oCol
lbl_Exit:
Exit Function
End Function
Sub ReplaceWords(ByVal strFind As String, ByVal strReplaceWith As String)
Dim oRng As Word.Range
'Add each term processed to a collection.
m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
Set oRng = ActiveDocument.Range
'Replace each instance of the English word with its Hebrew equivalent.
With oRng.Find
.Text = strFind
.Replacement.Text = strReplaceWith
.MatchWholeWord = True
.MatchCase = False
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub
Sub Underline_And_DefineFootnote()
Dim oRng As Word.Range
Dim lngIndex As Long
Dim oWord As Word.Range
Dim strWord As String
Dim lngCounter As Long
Dim lngPages As Long
With ActiveDocument
Set oRng = .Range
lngPages = .ComputeStatistics(wdStatisticPages)
For lngIndex = 1 To lngPages
Reprocess:
Set m_oCol2 = New Collection
Set oRng = oRng.GoTo(What:=wdGoToPage, Name:=lngIndex)
Set oRng = oRng.GoTo(What:=wdGoToBookmark, Name:="\page")
lngCounter = 1
With oRng
For Each oWord In oRng.Words
'Modify the word range to strip off white space. We want only the text portion of the word range.
strWord = UCase(Trim(oWord.Text))
oWord.Collapse wdCollapseStart
oWord.MoveEnd wdCharacter, Len(strWord)
If oWord.Characters.Last = Chr(160) Then oWord.MoveEnd wdCharacter, -1
'We need to know if the text defined by the word range is a word we want to process.
'We added all of those words to a collection during the find and replace process.
'If we try to add one of those words to the collection again then it will error and we will know _
we are dealing with a word we want to process.
On Error Resume Next
m_oCol1.Add strWord, strWord
If Err.Number <> 0 Then
On Error GoTo 0
On Error Resume Next
'We only want to underline and footnote the first instance of the term on each page.
'So add the term and key to a collection.
m_oCol2.Add strWord, strWord
oWord.Font.Underline = 1
If Err.Number = 0 Then
'There was no error so underline the term and footnote it.
'oWord.Font.Underline = 1
On Error GoTo 0
ActiveDocument.Footnotes.Add oWord, CStr(lngCounter), LCase(strWord)
lngCounter = lngCounter + 1
End If
Else
'The word wasn't a word we want to process so remove it from the collection.
m_oCol1.Remove m_oCol1.Count
End If
Next oWord
End With
'Since processing words will add footnotes, the length of the document will increase.
'I'm using this method to reenter the processing loop.
lngPages = .ComputeStatistics(wdStatisticPages)
If lngIndex < lngPages Then
lngIndex = lngIndex + 1
GoTo Reprocess
End If
Next lngIndex
End With
Set oRng = Nothing
End Sub
Sub FixFootnotes(ByVal strFind As String, ByVal strReplaceWith As String)
Dim oRng As Word.Range
m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng.Find
.Text = strFind
.Replacement.Text = strReplaceWith
.MatchWholeWord = True
.MatchCase = False 'True
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub
1 of 2 class modules (clsTerm):
Option Explicit
Private msEnglish As String
Private msHebrew As String
Private msFootnote As String
Public Property Let English(ByVal sEnglish As String): msEnglish = sEnglish: End Property
Public Property Get English() As String: English = msEnglish: End Property
Public Property Let Hebrew(ByVal sHebrew As String): msHebrew = sHebrew: End Property
Public Property Get Hebrew() As String: Hebrew = msHebrew: End Property
Public Property Let Footnote(ByVal sFootnote As String): msFootnote = sFootnote: End Property
Public Property Get Footnote() As String
Footnote = msEnglish & ":" & msHebrew & " - " & msFootnote
End Property
2 of 2 class modules (clsTerms):
Option Explicit
Private mcolTerms As Collection
Private lngCount As Long
Property Get Items() As Collection
Set Items = mcolTerms
End Property
Property Set Items(oCol As Collection)
Set mcolTerms = oCol
End Property
Property Get Count() As Long
If Not mcolTerms Is Nothing Then
Count = mcolTerms.Count
Else
Count = 0
End If
End Property
Public Sub FillFromExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim vaWords As Variant
Dim cTerm As clsTerm
Dim i As Long
Const sFILE As String = "C:\Documents and Settings\Administrator\Desktop\Macro Latest Accomplishments\this_feeds_AlexfromZackMacro.xlsx"
Const xlUP As Long = -4162
Set mcolTerms = New Collection
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(sFILE, , True)
With xlWb.Worksheets(1)
'changed 2 to 3 to get column c
vaWords = .Range("A1", .Cells(.Rows.Count, 3).End(xlUP)).Value
End With
'change footnote to store column c
For i = LBound(vaWords, 1) To UBound(vaWords, 1)
Set cTerm = New clsTerm
cTerm.English = vaWords(i, 1)
cTerm.Hebrew = vaWords(i, 2)
cTerm.Footnote = vaWords(i, 3)
mcolTerms.Add cTerm
Next i
xlWb.Close False
xlApp.Quit
End Sub
Come of my variable names may have changed since the last answer, so you'll need to make it all mesh together. Change your Term class to this
Option Explicit
Private msEnglish As String
Private msHebrew As String
Private msFootnote As String
Public Property Let English(ByVal sEnglish As String): msEnglish = sEnglish: End Property
Public Property Get English() As String: English = msEnglish: End Property
Public Property Let Hebrew(ByVal sHebrew As String): msHebrew = sHebrew: End Property
Public Property Get Hebrew() As String: Hebrew = msHebrew: End Property
Public Property Let Footnote(ByVal sFootnote As String): msFootnote = sFootnote: End Property
Public Property Get Footnote() As String
Footnote = msEnglish & ":" & msHebrew & " - " & msFootnote
End Property
This makes the Let part of Footnote a place to store what you have in column C. The Get part then let's you define how you want to output the footnote. In this example, I'm reading in column C (in the next section), but when I get the footnote property, it concatenates some other terms - it's not a straight read-back of what is in column C. You can change the Get part of Footnote to make it whatever you want.
Next you need to change how the Excel file is read in.
Public Sub FillFromExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim vaWords As Variant
Dim clsTerm As cTerm
Dim i As Long
Const sFILE As String = "C:\Users\Dick\Documents\My Dropbox\Excel\wordlist.xlsx"
Const xlUP As Long = -4162
Set mcolTerms = New Collection
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(sFILE, , True)
With xlWb.Worksheets(1)
'changed 2 to 3 to get column c
vaWords = .Range("A1", .Cells(.Rows.Count, 3).End(xlUP)).Value
End With
'change footnote to store column c
For i = LBound(vaWords, 1) To UBound(vaWords, 1)
Set clsTerm = New cTerm
clsTerm.English = vaWords(i, 1)
clsTerm.Hebrew = vaWords(i, 2)
clsTerm.Footnote = vaWords(i, 3)
mcolTerms.Add clsTerm
Next i
xlWb.Close False
xlApp.Quit
End Sub
I increased the range to include Column C. Before, Footnote was a concatenation of A and B. Now it is whatever is in column C and the concatenation is done in the class, where it should be.
I didn't save the file from the last question, so some of the variables and property names may have changed. Hopefully it's clear enough that you can adapt it.