Замена строки Excel VBA в Word

У меня есть фрагмент кода, который извлекает данные из моей книги Excel в массив, а затем заполняет список в документе Word. В документе имеется несколько списков, каждый из которых имеет уникальный заполнитель. Код работает отлично для 5 списков из 6, но по какой-то причине объединяет все массивы во второй список. Фрагмент кода ниже:

    ' Loop through each row in ManagerArray
    For row = LBound(ManagerArray) To UBound(ManagerArray)
        ' Replace placeholder with ManagerArray row content
        wdoc.Content.Find.Execute FindText: = "<<ManagerCriteria>>", ReplaceWith:=ManagerArray(row), Replace:=wdReplaceAll
    
        ' Insert new line and placeholder after the replaced content if it's not the last row
        If row < UBound(ManagerArray) Then
            wdoc.Content.Find.Execute FindText:=ManagerArray(row), ReplaceWith:=ManagerArray(row) & vbCr & "<<ManagerCriteria>>", Replace:=wdReplaceAll
        End If
    Next row

    
    ' Loop through each row in BRArray
    For row = LBound(BRArray) To UBound(BRArray)
        ' Replace placeholder with BRArray row content
        wdoc.Content.Find.Execute FindText: = "<<BRCriteria>>", ReplaceWith:=BRArray(row), Replace:=wdReplaceAll
    
        ' Insert new line and placeholder after the replaced content if it's not the last row
        If row < UBound(BRArray) Then
            wdoc.Content.Find.Execute FindText:=BRArray(row), ReplaceWith:=BRArray(row) & vbCr & "<<BRCriteria>>", Replace:=wdReplaceAll
        End If
    Next row

    
    ' Loop through each row in AIMArray
    For row = LBound(AIMArray) To UBound(AIMArray)
        ' Replace placeholder with AIMArray row content
        wdoc.Content.Find.Execute FindText: = "<<AIMCriteria>>", ReplaceWith:=AIMArray(row), Replace:=wdReplaceAll
    
        ' Insert new line and placeholder after the replaced content if it's not the last row
        If row < UBound(AIMArray) Then
            wdoc.Content.Find.Execute FindText:=AIMArray(row), ReplaceWith:=AIMArray(row) & vbCr & "<<AIMCriteria>>", Replace:=wdReplaceAll
        End If
    Next row

    
    ' Loop through each row in EISArray
    For row = LBound(EISArray) To UBound(EISArray)
        ' Replace placeholder with EISArray row content
        wdoc.Content.Find.Execute FindText: = "<<EISCriteria>>", ReplaceWith:=EISArray(row), Replace:=wdReplaceAll
    
        ' Insert new line and placeholder after the replaced content if it's not the last row
        If row < UBound(EISArray) Then
            wdoc.Content.Find.Execute FindText:=EISArray(row), ReplaceWith:=EISArray(row) & vbCr & "<<EISCriteria>>", Replace:=wdReplaceAll
        End If
    Next row

    
    ' Loop through each row in SEISArray
    For row = LBound(SEISArray) To UBound(SEISArray)
        ' Replace placeholder with SEISArray row content
        wdoc.Content.Find.Execute FindText: = "<<SEISCriteria>>", ReplaceWith:=SEISArray(row), Replace:=wdReplaceAll
    
        ' Insert new line and placeholder after the replaced content if it's not the last row
        If row < UBound(SEISArray) Then
            wdoc.Content.Find.Execute FindText:=SEISArray(row), ReplaceWith:=SEISArray(row) & vbCr & "<<SEISCriteria>>", Replace:=wdReplaceAll
        End If
    Next row

    
    ' Loop through each row in VCTArray
    For row = LBound(VCTArray) To UBound(VCTArray)
        ' Replace placeholder with VCTArray row content
        wdoc.Content.Find.Execute FindText: = "<<VCTCriteria>>", ReplaceWith:=VCTArray(row), Replace:=wdReplaceAll
    
        ' Insert new line and placeholder after the replaced content if it's not the last row
        If row < UBound(VCTArray) Then
            wdoc.Content.Find.Execute FindText:=VCTArray(row), ReplaceWith:=VCTArray(row) & vbCr & "<<VCTCriteria>>", Replace:=wdReplaceAll
        End If
    Next row

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

Пробовал выделить заменяемую часть в отдельную подпрограмму, но это не решило проблему.

Когда возникает эта ошибка: при первоначальной замене или в случае строки If < UBound(BRArray)? Вы можете использовать объединение массива вместо его цикла.

— 30.05.2024 12:32

excel vba ms-word

30.05.2024 11:40

Преобразование HTML-таблицы в профессиональный документ Excel

Это самый простой способ создания Excel из HTML-таблицы.

Импорт excel в laravel в базу данных

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

Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Облегчите себе задачу двумя способами.

Первое — СУШИТЬ — не повторяйтесь. Вы упомянули о выделении общего кода в отдельную функцию, и это отличная идея.
Во-вторых, нужно упростить замену заполнителя данными массива.

В примере ниже показан эффективный метод. Как протестировано, он не дает сбоев при работе с несколькими массивами/заполнителями.

Option Explicit

Sub test()
    Dim mgrArray As Variant
    mgrArray = Split("first line,second line,third line,fourth line,last line", ",")
    
    Dim theWordApp As Word.Application
    Set theWordApp = AttachToMSWordApplication
    theWordApp.Visible = True
    
    Dim theDoc As Word.Document
    Set theDoc = theWordApp.Documents.Open("C:\temp\test.docx")
    
    CopyArrayToDoc mgrArray, "<<ManagerCriteria>>", theDoc
       
End Sub

Sub CopyArrayToDoc(ByRef theArray As Variant, _
                   ByVal tag As String, _
                   ByRef theDoc As Word.Document)
    '--- create the replacement multi-line string
    Dim newText As String
    Dim arrayRow As Long
    For arrayRow = LBound(theArray) To UBound(theArray)
        newText = newText & theArray(arrayRow) & vbCr
    Next arrayRow
    
    '--- replace the placeholder with the multi-line string
    theDoc.Content.Find.Execute FindText:=tag, _
                                ReplaceWith:=newText, _
                                Replace:=wdReplaceAll
End Sub

Public Function AttachToMSWordApplication() As Word.Application
    '--- finds an existing and running instance of MS Word, or starts
    '    the application if one is not already running
    Dim mswApp As Object
    On Error Resume Next
    Set mswApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        '--- we have to start one
        '    an exception will be raised if the application is not installed
        Err.Clear
        Set mswApp = CreateObject("Word.Application")
    End If
    Set AttachToMSWordApplication = mswApp
End Function

30.05.2024 16:05

Другие вопросы по теме

Выделите активные строки, игнорируя любую ячейку с цветом заливки

Для следующего цикла в Excel VBA создается больше выходных значений, чем ожидалось

Как ограничить ячейки в зависимости от того, куда нажимает пользователь?

Как копировать определенные ячейки с одного листа на другой, в разных строках с пробелами. Как-то использовать совпадение индексов?

Как скачать таблицу в Excel?

Переименуйте страницу в OneNote с помощью VBA, не можете применить изменения, не можете сохранить XML

VBA – рассчитать точную разницу между датами (краевые случаи)

Как проверить, содержит ли ячейка фигуру?

Макрос стал очень медленным после функции фильтра

Диалоговые окна vba-Access НАЙТИ существующее и/или получить новое имя файла

Замена строки Excel VBA в Word

Ответы 1

Другие вопросы по теме

Похожие вопросы