Word Macro copy data excel to word tables

[FaizanRoshan]

Hi every one,
I have fond a code for word doc that copy data form excel sheet to word tables with different criteria. I have 3 criteria to filter excel column"B", if Criteria 1 match with Col B data the copy next col cell data and paste in word doc table 1, and if criteria 2 match then paste cell data in Table 2 else check 3rd criteria if match paste cell value in 3rd table.
Criteria 1 = 07:00 to 15:00, Criteria 1 = 15:00 to 23:00, Criteria 1 = 23:00 to 07:00
Excel Col "B" have many value in each criteria so if criteria 1 match more then one value then paste all value in table 1 column 1 row by row.
Please help me to modify this code.
Thank you for advance help.

Sub InputExcel()


Set appExcel = CreateObject("Excel.Application")


Dim INP_File As Variant
Dim lngRows As Long
Dim LenMgs As Long
Dim NumberOfRows As String
Dim lnCountItems As Long


INP_File = appExcel.GetOpenFilename("Excel files (*.xlsx;*.xls),*.xlsx;*.xls", 2)


appExcel.Workbooks.Open INP_File


If INP_File > 0 Then


    LenMgs = appExcel.Worksheets("Sheet1").Range("B2").CurrentRegion.Rows.Count
    'NumberOfRows = appExcel.Worksheets("Sheet1").Range("B42").End(xlUp).Row
    
    'Set Rng = appExcel.Worksheets("Sheet1").Range(appExcel.Worksheets("Sheet1").Cells(4, 1), appExcel.Worksheets("Sheet1").Cells(LenMgs, 5))
    'Rng.Copy
    'appExcel.Worksheets("Sheet1").Range("A1:B5").Copy - This is working !! if I specify the range.
    'Selection.Paste


pasteRowIndex = 1
lnCountItems = 1


For r = 1 To LenMgs 'Loop through sheet1 and search for your criteria


    If Cell(r, Columns("B").Column).Value = "YourCriteria" Then 'Found


            'Copy the current row
            Rows(r).Select
            Selection.Copy


            'Switch to the word where you want to paste it & paste
            
            For Each wdCell In wdDoc.Tables(3).Columns(1).Cells
            wdCell.Range.Text = Selection(lnCountItems, r)
              lnCountItems = lnCountItems + 1
            Next wdCell


            'Next time you find a match, it will be pasted in a new row
            pasteRowIndex = pasteRowIndex + 1




           'Switch back to your table & continue to search for your criteria
            Sheets("Sheet1").Select
    End If
Next r
End If


appExcel.ActiveWorkbook.Close


appExcel.Quit


Set appExcel = Nothing


End Sub