Find and Replace from Excel to word problem - excel

Question

I am trying to do find replace from excel to word using vba, but the problem is, in some of the word table it is keeping field blank.
After adjusting the table height in word it works but sometime it disturbs the other table and some time it paste as an image instead of text.
Below is the program which i have written for find and replace. Can anyone help me on below program. Thanks in advance.
Sub replication()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim wd As Word.Application
Dim wdDoc As Word.Document
Dim irow As Long
Dim i As Long
Dim k As Long
Dim sh As Worksheet
Set wd = New Word.Application
Set sh = ThisWorkbook.Sheets("Sheet1")
irow = 3
i = Application.WorksheetFunction.CountA(Sheet1.Range("A2:IZ2").Value)
Do While sh.Range("A" & irow).Value <> ""
Set wdDoc = wd.Documents.Open(ThisWorkbook.Path & "\Standard.docx")
wd.Visible = False
On Error Resume Next
wdDoc.SaveAs2 (ThisWorkbook.Path & "\Word\" & sh.Range("B" & irow).Value & ".docx")
For j = 2 To 3
With wdDoc.Content.Find
.Text = Sheet1.Cells(2, j)
.Replacement.Text = Sheet1.Cells(irow, j)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next j
For k = 4 To i
With wdDoc.Content.Find
.Text = Sheet1.Cells(2, k)
If Len(Sheet1.Cells(irow, k)) > 120 Then
Sheet1.Cells(irow, k).Copy
'Selection.PasteExcelTable False, False, False
.Replacement.Text = "^c"
.Replacement.ClearFormatting
Else
.Replacement.Text = Sheet1.Cells(irow, k)
.Replacement.ClearFormatting
End If
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
'.Range.ParagraphFormat.Alignment = 3
End With
Next k
Dim footr As Word.HeaderFooter
For Each footr In wdDoc.Sections(1).Footers
With footr.Range.Find
.Text = "<Scheme Name>"
.Replacement.Text = Sheet1.Cells(irow, 2)
.Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindStop
End With
Next footr
wd.Visible = False
Dim t As Table
'Windows(sh.Range("B" & irow).Value & ".docx").Activate
Documents(sh.Range("B" & irow).Value & ".docx").Activate
ActiveDocument.Range.Select
ActiveDocument.Range.Select
ActiveDocument.Range.Select
Documents(sh.Range("B" & irow).Value & ".docx").Activate
ActiveDocument.Range.Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
wdDoc.ExportAsFixedFormat OutputFileName:= _
ThisWorkbook.Path & "\PDF\" & sh.Range("B" & irow).Value & ".pdf" _
, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=138, _
Item:=wdExportDocumentWithMarkup, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
wdDoc.Close
Set wdDoc = Nothing
irow = irow + 1
Loop
wd.Quit
Set wd = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Replication done successfully!"
End Sub