Vba to existing word issue

[Largey980]

Anyone help me with the below show me where im going wrong???
Error listed below

--------------------------------

Sub all()

Dim wdapp As Object


On Error Resume Next
Set wdapp = GetObject(, "Word.Application")
On Error GoTo 0




If wdapp Is Nothing Then
MsgBox "No instances of Word found"
Exit Sub
End If




Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Dim Dict As Object
Dim RefList As Range, RefElem As Range




Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = Wbk.Sheets("Sheet1").Range("C2:C16")




With Dict
For Each RefElem In RefList
If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
.Add RefElem.Value, RefElem.Offset(0, 1).Value
End If
Next RefElem
End With




For Each Key In Dict
With wdapp.Application.Find 'run time error 438




If Dict(Key) = "" Then
.Execute FindText:=Key & "^p", ReplaceWith:=Dict(Key)
Else
.Execute FindText:=Key, ReplaceWith:=Dict(Key)
End If
End With
Next Key



End Sub

 

[Worf]

Like this:

' Excel module
Sub all()
Dim wdapp As Object, wr As Word.Range
Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Dim Dict As Object, key, RefList As Range, RefElem As Range
On Error Resume Next
Set wdapp = GetObject(, "Word.Application")
On Error GoTo 0
If wdapp Is Nothing Then
    MsgBox "No instances of Word found"
    Exit Sub
End If
Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = Wbk.Sheets("Sheet1").[C2:C16]
With Dict
    For Each RefElem In RefList
        If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then _
        .Add RefElem.Value, RefElem.Offset(, 1)
    Next
End With
Set wr = wdapp.ActiveDocument.Content
For Each key In Dict
    With wr.Find
        If Dict(key) = "" Then
            .Execute FindText:=key & "^p", ReplaceWith:=Dict(key)
        Else
            .Execute FindText:=key, ReplaceWith:=Dict(key)
        End If
    End With
Next key
End Sub

 

[Largey980]

Hi Worf, Thanks for assistance! This works in part and nearly perfect.

Only issue is; it only pastes the first line C2 (name) [stops]
Then click pastes second line C3(title) [stops]
Click C4(address1).........C5(address2), C6(postcode) etc

If you duplicate the process this works, but also replaces words in body of letter (name) and also entitlement becomes enMRSment.....

the address changes from 1/2/3 lines, so i can't replicate it a fixed number of times.

Any way to cycle through all at once, as original did - it found/replaced in order so always remained within letter head, with one full cycle C2:C16.

 

[Worf]

Hi

1) The new version below cycles it all, scanning the entire document.
2) I’m understanding you want to search only part of the document. Tell me what sections or pages you need to consider. Can you post a template with fake data?

Sub all()
Dim Wbk As Workbook, wdapp As Object: Set Wbk = ThisWorkbook
Dim Dict As Object, key, RefList As Range, RefElem As Range
On Error Resume Next
Set wdapp = GetObject(, "Word.Application")
On Error GoTo 0
If wdapp Is Nothing Then
    MsgBox "No instances of Word found"
    Exit Sub
End If
Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = Wbk.Sheets("Sheet1").[C2:C16]
With Dict
    For Each RefElem In RefList
        If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then _
        .Add RefElem.Value, RefElem.Offset(, 1)
    Next
End With
For Each key In Dict
    With wdapp.ActiveDocument.Content.Find
        If Dict(key) = "" Then
            .Execute findText:=key & "^p", ReplaceWith:=Dict(key)
        Else
            .Execute findText:=key, ReplaceWith:=Dict(key)
        End If
    End With
Next
End Sub

 

[Largey980]

There are a few lines between each of these but they always appear in top part of page, (extra stuff that appears is return address/date/few instructions) only problem is main boday after "Dear Name" Title First_Name Surname Address_1 Address_2 Address_3 Town County Postcode Ref: Dear Name ------------ Massive appreciation for assist with this

<tbody>
</tbody>

 

[Largey980]

I have tested the above and works fine, no residual issues.

I wouldn't mind getting more into coding, any suggestions on where best to begin Mr Worf?

 

[Worf]

Before seeing your last post, I wrote another version that will work only with the first page, stopping when the word dear is found.
Concerning Excel and VBA books, I like the work of John Walkenbach, google him to find out more.

' Excel module
Dim wdapp As Object, selrange As Word.Range, Dict As Object, _
key, RefList As Range, RefElem As Range, term1$, term2$, wr As Word.Range


Sub all()                                   ' run this one
On Error Resume Next
Set wdapp = GetObject(, "Word.Application")
On Error GoTo 0
If wdapp Is Nothing Then
    MsgBox "No instances of Word found"
    Exit Sub
End If
Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = ThisWorkbook.Sheets("Sheet1").[C2:C16]
With Dict
    For Each RefElem In RefList
        If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then _
        .Add RefElem.Value, RefElem.Offset(, 1)
    Next
End With
term1 = ActiveDocument.Words(1)
term2 = "Dear"
For Each key In Dict
    DefineRange
    With selrange.Find
        If Dict(key) = "" Then
            .Execute findText:=key & "^p", ReplaceWith:=Dict(key)
        Else
            .Execute findText:=key, ReplaceWith:=Dict(key)
        End If
    End With
Next
End Sub


Sub DefineRange()
Set wr = ActiveDocument.Range
With wr.Find
    .Text = term1
    .MatchWholeWord = True
    .Execute
    wr.Collapse wdCollapseEnd
    Set selrange = ActiveDocument.Range
    selrange.Start = wr.End
    .Text = term2
    .MatchWholeWord = True
    .Execute
    wr.Collapse wdCollapseStart
    selrange.End = wr.Start
End With
End Sub