Недопустимая погрешность подстроки – vba

Я пытаюсь скопировать и вставить несколько таблиц от Excel к слову, но это дает мне подстрочный код ошибки вне диапазона, когда я пытаюсь определить tbl. Я нашел коды онлайн и пытаюсь изменить коды в соответствии с моими потребностями.

Sub ExcelTablesToWord_Modified() Dim WordApp As Word.Application Dim myDoc As Word.Document Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") Dim sheet As Excel.Worksheet Dim tableName As String With dict .Add "TableA1", "TableA1" .Add "TableA2", "TableA2" .Add "TableB1", "TableB1" .Add "TableB2", "TableB2" .Add "TableC", "TableC" .Add "TableD", "TableD" .Add "TableE1", "TableE1" .Add "TableE2", "TableE2" .Add "TableF1", "TableF1" .Add "TableF2", "TableF2" 'TODO: add the remaining WorksheetName/TableName combinations End With 'Optimize Code Application.ScreenUpdating = False Application.EnableEvents = False 'Set Variable Equal To Destination Word Document On Error GoTo WordDocNotFound Set WordApp = GetObject(class:="Word.Application") WordApp.Visible = True Set myDoc = WordApp.Documents("a.docx") On Error GoTo 0 'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables For Each sheet In ActiveWorkbook.Worksheets tableName = dict(sheet.Name) 'Copy Table Range from Excel sheet.ListObjects(tableName).Range.Copy 'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5) myDoc.Bookmarks(tableName).Range.PasteExcelTable _ LinkedToExcel:=False, _ WordFormatting:=False, _ RTF:=False 'Autofit the most-recently-pasted Table so it fits inside Word Document myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow) Next sheet 'Completion Message MsgBox "Copy/Pasting Complete!", vbInformation GoTo EndRoutine 'ERROR HANDLER WordDocNotFound: MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16 'Put Stuff Back The Way It Was Found EndRoutine: 'Optimize Code Application.ScreenUpdating = True Application.EnableEvents = True 'Clear The Clipboard Application.CutCopyMode = False End Sub 

введите описание изображения здесь

введите описание изображения здесь

введите описание изображения здесь

Ниже будет скопирована первая таблица на каждом листе и вставьте в документ Word, независимо от имени таблицы. Имена закладок в документе Word, предположительно, начинаются с 1 с префиксом «bookmark».

Если требуются конкретные имена таблиц, тогда создайте коллекцию для имен и пропустите каждую таблицу в каждом листе, если это имя таблицы находится в коллекции, а затем перейдите к копированию.

 Option Base 1 'Force arrays to start at 1 instead of 0 Sub ExcelTablesToWord() Dim oWS As Worksheet Dim tbl As Excel.Range Dim WordApp As Object ' Word.Application Dim myDoc As Object ' Word.Document Dim x As Long ' Integer 'Optimize Code Application.ScreenUpdating = False Application.EnableEvents = False 'Set Variable Equal To Destination Word Document On Error Resume Next Set WordApp = GetObject(, "Word.Application") If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application") If WordApp Is Nothing Then GoTo WordDocNotFound WordApp.Visible = True Set myDoc = WordApp.Documents("a.docx") If myDoc Is Nothing Then Set myDoc = WordApp.Documents.Open("a.docx") If myDoc Is Nothing Then GoTo WordDocNotFound 'Loop Through and Copy/Paste Multiple Excel Tables x = 1 ' For x = LBound(TableArray) To UBound(TableArray) For Each oWS In ThisWorkbook.Worksheets 'Copy Table Range from Excel 'Set tbl = ThisWorkbook.Worksheets(x).ListObjects(TableArray(x)).Range Set tbl = oWS.ListObjects(1).Range If Not tbl Is Nothing Then tbl.Copy 'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5) myDoc.Bookmarks("bookmark" & x).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False 'Autofit Table so it fits inside Word Document myDoc.Tables(x).AutoFitBehavior 2 ' (wdAutoFitWindow) x = x + 1 End If Next On Error GoTo 0 'Completion Message MsgBox "Copy/Pasting Complete!", vbInformation GoTo EndRoutine 'ERROR HANDLER WordDocNotFound: MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16 'Put Stuff Back The Way It Was Found EndRoutine: 'Optimize Code Application.ScreenUpdating = True Application.EnableEvents = True 'Clear The Clipboard Application.CutCopyMode = False End Sub 

Код, который я изначально предоставил, основывался на вашей исходной модели, в которой соответствующий Рабочий лист, Таблица и Закладка в каждом наборе имели другое имя.

Теперь, когда вы убедитесь, что имена объектов в каждом наборе идентичны (что является лучшей моделью), попробуйте выполнить следующую процедуру. Единственное отличие заключается в том, что Scripting.Dictionary был удален, а имя рабочего листа используется для предоставления имени таблицы и имени закладки (так как все три значения совпадают сейчас).

Как и раньше, этот был также протестирован в Excel / Word 2016 и функционирует как ожидалось:

 Public Sub ExcelTablesToWord_Modified2() Dim WordApp As Word.Application Dim myDoc As Word.Document Dim sheet As Excel.Worksheet 'Optimize Code Application.ScreenUpdating = False Application.EnableEvents = False 'Set Variable Equal To Destination Word Document On Error GoTo WordDocNotFound Set WordApp = GetObject(class:="Word.Application") WordApp.Visible = True Set myDoc = WordApp.Documents("a.docx") On Error GoTo 0 'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables For Each sheet In ActiveWorkbook.Worksheets 'Copy Table Range from Excel sheet.ListObjects(sheet.Name).Range.Copy 'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5) myDoc.Bookmarks(sheet.Name).Range.PasteExcelTable _ LinkedToExcel:=False, _ WordFormatting:=False, _ RTF:=False 'Autofit the most-recently-pasted Table so it fits inside Word Document myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow) Next sheet 'Completion Message MsgBox "Copy/Pasting Complete!", vbInformation GoTo EndRoutine 'ERROR HANDLER WordDocNotFound: MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16 'Put Stuff Back The Way It Was Found EndRoutine: 'Optimize Code Application.ScreenUpdating = True Application.EnableEvents = True 'Clear The Clipboard Application.CutCopyMode = False End Sub 

Если вы по-прежнему получаете ту же ошибку, возможно, рабочая книга повреждена. В этом случае попробуйте сделать следующее:

  1. Создайте новую рабочую книгу с одним рабочим листом
  2. Переименуйте рабочий лист так, чтобы его имя совпадало с именем одного из закладок в документе Word
  3. Вручную добавьте единую, небольшую таблицу «только для тестирования» на рабочий лист (не копируйте и не вставляйте одну из оригинальной книги)
  4. Убедитесь, что имя таблицы совпадает с именем рабочего листа
  5. Скопируйте / вставьте описанную выше процедуру в новый модуль в этой книге
  6. Сохранить новую книгу
  7. Убедитесь, что документ Word открыт, и выполните процедуру

Если это сработает, вы можете рассмотреть возможность воссоздания всей оригинальной книги в новой книге. При этом, если ваши наборы данных достаточно велики, чтобы вы могли скопировать / вставить из оригинальной книги, используйте «Вставить специальный» с «Только значения» вместо обычной вставки. Затем заново создайте любое отсутствующее форматирование вручную. Таким образом, будет менее вероятно, что любая коррупция в оригинальной книге будет перенесена на новую.

  • Создание текстовых документов из файла excel с использованием слияния
  • Есть ли способ инициировать «изменения трека» через VBA в Excel?
  • VBA Excel Отключение оттенков серого в Word Doc
  • Проверка выравнивания текста ячейки в Excel с помощью Word VBA 2007
  • Используя Word VBA для автоматизации Excel, я получаю ошибку времени выполнения «13»: тип несоответствия при использовании функции .Find
  • Копирование и вставка ВКЛЮЧАЯ закладки VBA
  • Добавление таблицы в документ Word через Excel 2010 VBA
  • Обновление кода Word VBA на 2013 год
  • Ссылка на уже открытый текстовый документ в VBA
  • Анализ HTML для воссоздания таблиц в документе Word с использованием VBA
  • проверить входные данные пользователя в динамически добавленные ComboBoxes
  • Давайте будем гением компьютера.