Выбор нескольких документов (VBA скрипт, который позволяет переносить данные из Word в Excel)

[MBura]

Здравствуйте.
У меня есть скрипт, который позволяет переносить данные из Word в Excel, но по одному. Не получается осуществить выбор нескольких файлов, не могли бы помочь?

Sub CopyOldWordDoc()
Dim a As Variant, MainBook As Workbook, CurrentSheet As String
 Set MainBook = ActiveWorkbook
 CurrentSheet = ActiveSheet.Name
              Dim FD As FileDialog
              Dim iFileName As String
              Dim Book As Workbook
              Dim CheckNameBook As String
       Set FD = Application.FileDialog(msoFileDialogFilePicker)
       With FD
             .Filters.Clear
             '.Filters.Add "Microsoft Word files", "*.doc"
             .Filters.Add "All files", "*.*"
             .AllowMultiSelect = False
             .InitialFileName = ThisWorkbook.Path
             .Title = "Открытие документа"
             .ButtonName = "Открыть"
            If .Show = False Then
               MsgBox "Вы не указали файл - источник!", 48, "Ошибка"
               Exit Sub
            Else
               iFileName = .SelectedItems(1)
            End If
         End With
         Set FD = Nothing

        ' Открытие документа Word и копирование содержимого в новый лист

    Dim WordApp As Object, CopyArea As Variant
     Set WordApp = CreateObject("Word.Application")
       WordApp.Application.Visible = False
       WordApp.Documents.Open Filename:=iFileName
       With WordApp.ActiveDocument
           Set CopyArea = .Range(0, .Characters.Count)
               CopyArea.Select
               WordApp.Selection.Copy
       End With
       
     'создаем новый лист для переноса
     Set wsDataSheet = ActiveWorkbook.Sheets.Add(after:=Sheets(Sheets.Count))
     Dim TempBook As Workbook
     Set TempBook = ActiveWorkbook
         'TempBook.Worksheets(1).Cells.NumberFormat = "@"
         'TempBook.Worksheets(1).Range("A1").Select
         ActiveSheet.Paste
         'Application.CutCopyMove = False
         WordApp.Quit
        
 MainBook.Activate
 Worksheets(CurrentSheet).Activate
 Range("A1").Activate
End Sub

________
Код нужно оформлять по правилам:
тегом [CODE]..[/СODE]
(это кнопочка на панели форматирования с решёточкой #)
Не забывайте об этом!

Модератор.