Excel not responding or error 462
 

Hello,

I have two problems with the macro here under. For j=2 is everything ok. But
if I go to the next (j=3) then or excel crashes at
€œWindows(bediendexls).Activate€� or I get the 462 runtime error at
€œActiveDocument.Fields.Unlink€� in €œSub OpenAndReadWordDoc(i As String)€�. Is
there anyone who can help me?

Thanks,
Jan


Sub main()
Dim kader As String
Dim kaderxls As String
Dim bediende As String
Dim bediendexls As String
Dim arbeider As String
Dim arbeiderxls As String
kader = "D:\survey04\chapter 6 kader.xls"
kaderxls = "Hoofdstuk6 kader.xls"
bediende = "D:\Survey04\chapter 6 bediende.xls"
bediendexls = "Hoofdstuk6 bediende.xls"
arbeider = "D:\Survey04\chapter 6 arbeiders.xls"
arbeiderxls = "Hoofdstuk6 arbeiders.xls"
Workbooks.Open Filename:=kader, UpdateLinks:=1
Sheets("code").Select
Workbooks.Open Filename:=bediende, UpdateLinks:=1
Sheets("code").Select
Workbooks.Open Filename:=arbeider, UpdateLinks:=1
Sheets("code").Select
Windows("reports.xls").Activate

For j = 2 To 200
'kopieer cijfer naar hoofdstuk 6 kader, bediende, arbeider
Windows("reports.xls").Activate
Cells(j, 1).Select
Selection.Copy
Windows(kaderxls).Activate
Cells(4, 2).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Windows("reports.xls").Activate
Cells(j, 1).Select
Selection.Copy
Windows(bediendexls).Activate (STOPS HERE OR)
Cells(4, 2).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Windows("reports.xls").Activate
Cells(j, 1).Select
Selection.Copy
Windows(arbeiderxls).Activate
Cells(4, 2).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
'word openen, opslaan, sluiten
Windows("reports.xls").Activate
OpenAndReadWordDoc (Cells(j, 2))
Next j
'close chapter 6
Windows(kaderxls).Activate
ActiveWorkbook.Close (False)
Windows(bediendexls).Activate
ActiveWorkbook.Close (False)
Windows(arbeiderxls).Activate
ActiveWorkbook.Close (False)
End Sub

Sub OpenAndReadWordDoc(i As String)
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("D:\Survey04\chapter 6 with links.doc")
ActiveDocument.Fields.Unlink (OR STOPS HERE, error 462)
Unlinkexcel €˜unlink excel graphics
unlinkfooter
With wrdDoc
.SaveAs ("D:\Survey04 \" & i & ".doc")
.Close ' close the document
End With
Set wrdDoc = Nothing
wrdApp.Quit ' close the Word application
Set wrdApp = Nothing
'ActiveWorkbook.Saved = True
End Sub