Dim oExcel As Object
Dim eBook As Object

Dim formatCell As String
Sub ImportData()

    Dim ExcelFileName As String
    Dim Dated As Date
    
    ExcelFileName = SelectFile("Excel", "xlsm")
    If ExcelFileName = "" Then MsgBox "Excel file not selected - Import canceled.", vbInformation: Exit Sub
    
    Dim wDoc As Document
    
    Set wDoc = ActiveDocument
    Set oExcel = CreateObject("Excel.Application")
    Set eBook = oExcel.Workbooks.Open(ExcelFileName)
    
    'oExcel.Visible = True
    
    Application.StatusBar = "Please be patient as the data is imported..."
    Application.ScreenUpdating = False
    'On Error GoTo 10
    
    Dim tbl As Table
    Dim iSource As String
    Dim fValue As String
    
    Dim cl As Cell
    
    Dim item As Bookmark
    Dim itemName As String
    Dim a As Long
    
    For a = wDoc.Bookmarks.Count To 1 Step -1
            Set item = wDoc.Bookmarks(a)
                itemName = item.Name
            Set cl = item.Range.Cells(1)
                fValue = RangeValue(itemName)
                    If fValue <> "" Then
                        If IsNumeric(fValue) Then
                            Select Case formatCell
                                Case "Percentage"
                                    item.Range.Text = Format(fValue, formatCell)
                                Case "0%"
                                    item.Range.Text = Format(fValue, formatCell)
                                Case "0.0%"
                                    item.Range.Text = Format(fValue, formatCell)
                                Case "0.00%"
                                    item.Range.Text = Format(fValue, formatCell)
                                Case "0.00""x"""
                                    item.Range.Text = Format(fValue, "0.00""x""")
                                Case Else
                                    item.Range.Text = Format(fValue, "#,##0;(#,##0);"" - """)
                            End Select
                        Else
                            item.Range.Text = fValue
                        End If
                    End If
            wDoc.Bookmarks.Add itemName, cl.Range
    Next
    
    eBook.Close False
    oExcel.Quit
    Application.ScreenUpdating = True
    
    
    Set eSheet = Nothing
    Set eBook = Nothing
    Set oExcel = Nothing
    DoEvents
    Application.StatusBar = ""
    MsgBox "Import Completed.", vbInformation
    Exit Sub
10:
    eBook.Close False
    oExcel.Quit
    Application.ScreenUpdating = True
    Set eSheet = Nothing
    Set eBook = Nothing
    Set oExcel = Nothing
    MsgBox Err.Description
End Sub


Private Function SelectFile(FileTypeName As String, FileType As String) As String
    
    Dim FD As FileDialog
    
    SelectFile = ""
    
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .Title = "Select " & FileTypeName & " file"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add FileTypeName & " File", "*." & FileType
    End With
    If FD.Show = -1 Then
        SelectFile = FD.SelectedItems(1)
    End If

End Function

Private Function RangeValue(RangeName As String) As String

    Dim i As Long
    Dim RangeToFind As Range
    Dim str As String

    Err.Clear
    On Error Resume Next
    With eBook
        For i = 1 To .Sheets.Count
            str = .Sheets(i).Range(RangeName).Value
            If Err.Number = 0 Then
                RangeValue = str
                formatCell = .Sheets(i).Range(RangeName).NumberFormat

                Exit For
            Else
                Err.Clear
            End If
        Next i
    End With
    On Error GoTo 0
    Err.Clear
End Function