Find word value in excel and insert related cell value as text

[GenuineGin]

Hello again :)

I am having trouble with the piece of code below. What I want to happen is it runs through column 4 of the workbook, finds text that matches the cell value in the word document and inserts the related value in column 2 after it.


Sub FindReplaceExcel()
Dim xlApp 'As Excel.Application
Dim xlWB 'As Excel.Workbook
Dim idx As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open("R:\GUIDANCE\Vegetation\BSBI Checklist 2007.xls")
For idx = 1 To 7852
'MsgBox "Adding " & xlWB.Worksheets(1).Cells(idx, 2) & " to " & xlWB.Worksheets(1).Cells(idx, 4)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = xlWB.Worksheets(1).Cells(idx, 4)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Selection.InsertAfter (xlWB.Worksheets(1).Cells(idx, 2))
End With
Next
xlWB.Close False
xlApp.Quit
Set xlWB = Nothing
Set xlApp = Nothing
End Sub



The issue I'm having is instead of inserting only the column 2 value of the matching row, it inserts all the values in column 2! I'm assuming this has something to do with


Selection.InsertAfter (xlWB.Worksheets(1).Cells(idx, 2))

Where "idx" leads the code to cycle through the entire workbook again, but I can't work out how to reference the specific row in any other way.

Any help gratefully received.

[Doug Robbins]

Use:


Dim xlApp As Object
Dim xlWB As Object
Dim idx As Integer
Dim strTexttoFind As String
Dim strTexttoInsert As String
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.WOrkbooks.Open("R:\GUIDANCE\Vegetation\BSBI Checklist 2007.xls")
With xlWB.Sheets(1).Range("A1")
For idx = 1 To .CurrentRegion.Rows.Count
strTexttoFind = .Offset(idx - 1, 3)
strTexttoInsert = .Offset(idx - 1, 1)
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = strTexttoFind
If .Execute = True Then
Selection.InsertAfter strTexttoInsert
End If
End With
Next
End With
xlWB.Close False
xlApp.Quit
Set xlWB = Nothing
Set xlApp = Nothing
End Sub

[GenuineGin]

Great, thanks!