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.
Related
Thank you in advance, I need help in completing the below code, the code currently works to add the number of rows in the Table(3) of my word template as per the available rows in excel table, the word template have one row to begin with.
How can I pass the value from excel table range Set Rng = wsSheet.Range("A2:C" & lastrow)
Option Explicit
Sub CopyToWordTemplate()
Const stWordDocument As String = "TemplateSD.docm"
Dim intNoOfRows
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lRow, i, lastrow, lastcol As Long
Dim vaData As Variant
Dim Rng As Range
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Transmittal")
lastrow = wsSheet.Range("A2").End(xlDown).Row
lastcol = wsSheet.Range("C2").End(xlToRight).Column
Set Rng = wsSheet.Range("A2:C" & lastrow)
Rng.ClearContents
Copy_Criteria_Text
lRow = wsSheet.Range("A2").End(xlDown).Row
intNoOfRows = lRow - 1
Set objWord = New Word.Application
objWord.Visible = True
Set objDoc = objWord.Documents.Open("\\Dn71\dn071\DOCUMENT CONTROL\Common\X-
Templates\Document Control\" & stWordDocument)
With objWord.ActiveDocument
.Bookmarks("Description").Range.Text = wsSheet.Range("D1").Value
.Bookmarks("RevNumber").Range.Text = "C" & wsSheet.Range("E1").Value
.Bookmarks("SubmittalNumber").Range.Text = "DN071-P02-CRC-GEN-PMT-SDA-" & wsSheet.Range("F1").Value
End With
For i = 2 To intNoOfRows
objDoc.Tables(3).Rows.Add
Next
Set objWord = Nothing
End Sub
I'm struggling trying to export a Word table to an Excel sheet, while preserving the number formatting. My code works as shown below, but the part I commented out is how I'm currently trying to do it (and failing). Could someone point out what I'm doing wrong?
Public Sub CopyTableToExcel()
Dim xlApp As Excel.Application
Dim xlwb As Excel.Workbook
Dim doc As Word.Document
Dim tbl As Word.Table
Dim lastRow As Long, lastColumn As Integer
Dim tblRange As Word.Range
Dim excelRange As Excel.Range
Set doc = ThisDocument
Set xlApp = CreateObject("Excel.Application")
Set xlwb = xlApp.Workbooks.Add 'Create new workbook
Set tbl = doc.Tables(2)
With tbl:
lastRow = .Rows.Count
lastColumn = .Columns.Count
Set tblRange = .Cell(1, 1).Range
tblRange.End = .Cell(lastRow, lastColumn).Range.End
tblRange.Copy
xlwb.Worksheets(1).Paste
'This part doesn't work, but I'm trying to do something like this:
'Set excelRange = xlwb.Worksheets("Sheet1").Range("A1")
'excelRange.PasteSpecial (xlPasteValuesAndNumberFormats)
End With
Set xlwb = Nothing
Set xlApp = Nothing
Set tbl = Nothing
Set doc = Nothing
End Sub
Thanks for your help!
I would like to atomatize an excel process using VBA.
The script has to go cell by cell in a selected area on Sheet3. Each cell contains a number or is blank.
The script will go and search for the value of each cell in a specific range on Sheet2. When it finds something the content of the whole row where it was found must go bold.
If it finds nothing it will just procede to the next cell.
After browsing here on stackoverflow and different guides I've managed to put together a script. It has no errors but it doesn't do Anything.
Sub MacroText()
Dim xlRng As Range
Dim rng As Range
Dim xlSht As Worksheet
Dim sht As Worksheet
Dim iLastRow As Integer
Dim iRow As Integer
Dim bFound As Boolean
Dim xCell As Range
Dim xlCell As Range
Dim valueToFind As String
bFound = False
Set sht = ActiveWorkbook.Worksheets("Sheet3")
Set xlSht = ActiveWorkbook.Worksheets("Sheet2")
Set rng = Selection
Set xlRng = ActiveWorkbook.Worksheets("Sheet2").Range("A:A")
iLastRow = xlSht.Range("A1").End(xlDown).Row
Set xlRng = xlSht.Range("A1:A" & iLastRow)
For Each xCell In rng
valueToFind = xCell.Value
For Each xlCell In xlRng
Worksheets("Sheet2").Activate
If xlCell.Value = valueToFind Then
bFound = True
iRow = xlCell.Row
Rows(iRow).Font.Bold = True
End If
If bFound = True Then Exit For
End
Next xlCell
Next xCell
End Sub
I am assuming that it has to be something with positioning within the code but I couldn't find any information for that.
After working on this for 12 hours I would really appreciate your help.
Cheers!
You could use the Find method to achieve this instead of the second loop
Sub MacroText()
Dim xlRng As Range
Dim rng As Range
Dim xlSht As Worksheet
Dim sht As Worksheet
Dim iLastRow As Long
Dim iRow As Long
Dim bFound As Boolean
Dim xCell As Range
Dim xlCell As Range
Dim valueToFind As String
Dim FoundRange As Range
bFound = False
Set sht = ActiveWorkbook.Worksheets("Sheet3")
Set xlSht = ActiveWorkbook.Worksheets("Sheet2")
Set rng = Selection
Set xlRng = ActiveWorkbook.Worksheets("Sheet2").Range("A:A")
iLastRow = xlSht.Range("A1").End(xlDown).Row
Set xlRng = xlSht.Range("A1:A" & iLastRow)
For Each xCell In rng
Set FoundRange = Nothing
Set FoundRange = xlRng.Find(what:=xCell.Value2)
If Not FoundRange Is Nothing Then
FoundRange.EntireRow.Font.Bold = True
End If
Next xCell
End Sub
For Each xlCell In xlRng
Worksheets("Sheet2").Activate
If xlCell.Value = valueToFind Then
xlCell.EntireRow.Font.Bold = True
End If
Next xlCell
I don't know what thing you are not getting, but I assumed that you are not getting desired row as bold. Replace the above code with your's for loop and run.
I didn't tested it, but am uncertain about not working.
I'm getting Run-time error 91 on several variable, and I really have no idea what I'm doing wrong...
The variables are: IQRngRef, tempRng, unionVariable
I assume it has something with them all being arrays with the exception of unionVariable (at least it shouldn't be).
Could I get some help here please?
Option Explicit
Private Sub averageScoreRelay()
' 1. Run from PPT and open an Excel file
' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72".
' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table.
' 4. Copy table from xl Paste Table into ppt
' 5. Do this for every slide
'Timer start
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ShRef As Excel.Worksheet
Dim pptPres As Object
Dim colNumb As Long
Dim rowNumb As Long
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
'xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\Pinlop\Desktop\Gate\Macros\averageScores\pptxlpratice\dummy2.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
xlApp.DisplayAlerts = False
'Find # of iq's in workbook
Set ShRef = xlWB.Worksheets("Sheet1")
colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
rowNumb = ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp).Row
Dim IQRef() As String
Dim iCol As Long
Dim IQRngRef() As Range
ReDim IQRef(colNumb)
ReDim IQRngRef(colNumb)
' capture IQ refs locally
For iCol = 2 To colNumb
IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol)).Value
IQRef(iCol) = ShRef.Cells(1, iCol).Value
Next iCol
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Create variables for the slide loop
Dim pptSlide As Slide
Dim Shpe As Shape
Dim pptText As String
Dim iq_Array As Variant
Dim arrayLoop As Long
Dim myShape As Object
Dim outCol As Long
Dim i As Long
Dim lRows As Long
Dim lCols As Long
Dim k As Long
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
i = 0
pptSlide.Select
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
If Not Shpe.HasTextFrame Then GoTo nextShpe 'boom, one less nested If statement
If Not Shpe.TextFrame.HasText Then GoTo nextShpe ' boom, another nested If statement bites the dust
outCol = 0
'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters
pptText = Shpe.TextFrame.TextRange
pptText = LCase(Replace(pptText, " ", vbNullString))
pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)
'Identify if within text there is "iq_"
If InStr(1, pptText, "iq_") <= 0 Then GoTo nextShpe
'set iq_Array as an array of the split iq's
iq_Array = Split(pptText, ",")
Dim hasIQs As Boolean
Dim checkStr As String
Dim pCol As Long
Dim checkOne
checkOne = iq_Array(0)
hasIQs = Left(checkOne, 3) = "iq_"
Dim tempRng() As Range
If hasIQs Then
' paste inital column into temporary worksheet
tempRng(0) = ShRef.Columns(1)
End If
' loop for each iq_ in the array
For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
' Take copy of potential ref and adjust to standard if required
checkStr = iq_Array(arrayLoop)
If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr
' Look for existence of corresponding column in local copy array
pCol = 0
For iCol = 2 To colNumb
If checkStr = IQRef(iCol) Then
pCol = iCol
Exit For
End If
Next iCol
If pCol > 0 Then
' Paste the corresponding column into the forming table
outCol = outCol + 1
tempRng(outCol) = ShRef.Columns(pCol)
End If
Next arrayLoop
If outCol > 1 Then 'data was added
' Copy table
Dim unionVariable As Range
unionVariable = tempRng(0)
For k = 1 To i
unionVariable = Union(unionVariable, tempRng(k))
Next k
unionVariable.Copy ' all the data added to ShWork
tryAgain:
ActiveWindow.ViewType = ppViewNormal
ActiveWindow.Panes(2).Activate
Set myShape = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
On Error GoTo tryAgain
On Error GoTo clrSht
'Set position:
myShape.Left = -200
myShape.Top = 150 + i
i = i + 150
End If
clrSht:
'Clear Sheet2 for next slide
Erase tempRng()
nextShpe:
Next Shpe
nextSlide:
Next pptSlide
xlWB.Close
xlApp.Quit
xlApp.DisplayAlerts = True
'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Dim something() As String
That's declaring a dynamically-sized array, where each item is a String. Once it's resized, you can do this (assuming i is within the boundaries of the array):
something(i) = "foo"
Now this:
Dim something() As Range
That's declaring a dynamically-sized array, where each item is a Range. Once it's resized, you can do this (assuming i is within the boundaries of the array):
Set something(i) = Range("A1")
Notice the Set keyword - it's required in VBA, whenever you're assigning an object reference. Range being an object, you need the Set keyword for that assignment.
In your code:
tempRng(0) = ShRef.Columns(1)
That's indeed a Range, but the Set keyword is missing. That will throw the RTE91 you're getting.
Same here:
unionVariable = tempRng(0)
You can't assign an object reference without the Set keyword.
Here though:
IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol)).Value
That's not a Range. It's the .Value of a Range, and that's a Variant - not an object, so adding the Set keyword isn't going to fix anything. If you mean IQRngRef to hold Range objects, you need to do this:
Set IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol))
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