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