Цикл VBA не отправляет данные в word согласованным образом

ProgramBox

Цикл VBA не отправляет данные в word согласованным образом

Post author:admin
Запись опубликована:21 марта, 2023
Post category:Вопросы по программированию

#vba #loops #ms-word #copy #paste

#vba #циклы #ms-word #Копировать #вставить

Вопрос:

У меня есть приведенный ниже код, который пока проходит через простую электронную таблицу и вставляет организацию, одну таблицу с одним значением ячейки и диаграмму в шаблон word. Код выполняется и выдает как word, так и PDF-версию правильно. Но я вижу, что таблица иногда оказывается там, где должна быть организация, и диаграмма повторяется в документе. Кажется, что каждый вывод цикла меняется, и я не могу понять, не очищается ли информация из буфера обмена перед ее вставкой. Нужно ли мне разбивать разделы на подразделы или что-то в этом роде?

Ценю помощь.

     Sub CreateBasicWordReport()
   Dim WdApp As Word.Application
   Dim wdDoc As Word.Document
   Dim SaveName As String
   Dim FileExt As String
   Dim LstObj1 As ListObject
   Dim MaxValue As Integer
   Dim FilterValue As Integer
   Dim Organisation As String
   Dim Rng As Range
   Dim WS As Worksheet
   
   Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
   
   MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
    
   FilterValue = MaxValue
    
   Set WdApp = CreateObject("Word.Application")
   Do Until FilterValue = 0
   
   Application.DisplayAlerts = False
    
      Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
      Sheets("Sheet1").Select
    
      'moved outside of loop
      ' Set WdApp = CreateObject("Word.Application")
   
      With WdApp
         .Visible = True
         .Activate
         'create new document and assign to object variable
         Set wdDoc = .Documents.Add("C:UsersdavidDocumentsCustom Office TemplatesTemplate2.dotx")
      'now mostly finished with WdApp as from here wdDoc is used
      End With
      ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
      Range("F11").Select
              
      Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
    
      '         .Selection.GoTo what:=-1, Name:="TableLocation"
      '         .Selection.Paste
      wdDoc.Bookmarks("TableLocation").Range.Paste
    
      For Each Row In Range("Table1[#All]").Rows
         If Row.EntireRow.Hidden = False Then
            If Rng Is Nothing Then Set Rng = Row
            Set Rng = Union(Row, Rng)
         End If
      Next Row
      Set WS = Sheets("Static")
      Rng.Copy Destination:=WS.Range("A1")

      '      Sheets("Static").Select
      '      Sheets("Static").Activate
      Organisation = WS.Range("D2").Value
    
      '      Sheets("Static").Select
      '      Range("D2").Copy
      WS.Range("D2").Copy
      
      '         .Selection.GoTo what:=-1, Name:="Organisation"
      '         .Selection.PasteAndFormat wdFormatPlainText
      wdDoc.Bookmarks("Organisation").Range.PasteAndFormat wdFormatPlainText
      Application.CutCopyMode = False
    
      '      Sheets("Static").Select
      '      Range("F2").Copy
      WS.Range("F2").Copy
      
    
      '         .Selection.GoTo what:=-1, Name:="MalePatients"
      '         .Selection.PasteAndFormat wdFormatPlainText
      wdDoc.Bookmarks("MalePatients").Range.PasteAndFormat wdFormatPlainText
         
      Application.CutCopyMode = False
    
      Chart2.ChartArea.Copy
    
      '         .Selection.GoTo what:=-1, Name:="ChartLocation"
      '         .Selection.Paste
      wdDoc.Bookmarks("ChartLocation").Range.Paste
    
      If WdApp.Version <= 11 Then
         FileExt = ".doc"
      Else
         FileExt = ".docx"
      End If
    
      SaveName = Environ("UserProfile") amp; "DesktopReport for " amp; _
         Organisation amp; " " amp; _
         Format(Now, "yyyy-mm-dd hh-mm-ss") amp; FileExt
        
      If WdApp.Version <= 12 Then
         ' .ActiveDocument.SaveAs SaveName
         wdDoc.SaveAs SaveName
      Else
         ' .ActiveDocument.SaveAs2 SaveName
         wdDoc.SaveAs2 SaveName
      End If
    
      SaveNamePDF = Environ("UserProfile") amp; "DesktopReport " amp; _
         Organisation amp; " " amp; _
         Format(Now, "yyyy-mm-dd hh-mm-ss") amp; ".pdf"

      wdDoc.ExportAsFixedFormat _
         OutputFileName:=SaveNamePDF, _
         ExportFormat:=wdExportFormatPDF _
    
         wdDoc.Close
    
         FilterValue = FilterValue - 1
         Sheets("Static").Delete
         
   Application.DisplayAlerts = True
      
   Loop

   WdApp.Quit
    
   Set WdApp = Nothing
    
End Sub

Ответ №1:

Вы можете или не хотите воспринимать это как ответ на свой вопрос, но вот несколько способов улучшить свой код, чтобы получить лучший контроль над тем, как он работает. Это не «решение» в смысле завершенного, корректно работающего модуля кода, но если вы примете этот совет, он должен позволить вам решить проблему самостоятельно (наряду со многими другими проблемами, с которыми вы могли бы столкнуться в будущем).

(1) Избегайте использования Copy и Paste . Как вы правильно заметили, это ставит вас во власть буфера обмена Windows. Вместо этого присвоите исходный объект или значение переменной, а затем вставьте содержимое переменной в пункт назначения. Например:

 Organisation = WS.Range("D2").Value
wdDoc.Bookmarks("Organisation").Range.Text = Organisation

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

(2) Используйте With ... End With для явного указания родителей ваших объектов. Таким образом, вы не рискуете случайно ссылаться на другой объект, чем ожидали. Например, в этом отрывке из вашего кода …

 With WdApp
    Set wdDoc = .Documents.Add("C:UsersdavidDocumentsCustom Office TemplatesTemplate2.dotx")
End With

Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy

… диапазон, скопированный в последней строке, может быть не таким, как вы ожидаете. Если активным объектом в данный момент является ваш недавно созданный документ Word, Range объект может быть интерпретирован как некоторый диапазон в документе, а не диапазон электронной таблицы, который вы хотели скопировать.

Чтобы оставаться под контролем, используйте With последовательно:

 With WdApp
    Set wdDoc = .Documents.Add("C:UsersdavidDocumentsCustom Office TemplatesTemplate2.dotx")
End With

With MyWorkbook.Sheets("MySheet")
    Set MyTableRange = .Range("A1", .Range("A1").End(xlDown).End(xlToRight))
End With

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

1. Вы ошибаетесь во втором пункте. Поскольку код размещен в Excel Range , он всегда будет интерпретироваться как диапазон Excel. Единственная временная путаница возникает, если вы объявляете переменную, например Dim WdRange as Range , вместо Dim WdRange as Word.Range

2. … например, в объявлении Dim Rng As Range прямо здесь, в вопросе OP. Ваш комментарий сводится к идее, что OP будет в порядке, если продолжать полагаться на неявные ссылки, пока объявление переменной исправлено. На мой взгляд, это очень бесполезный совет (не для меня, а для нового программиста, который опубликовал этот вопрос).

3. Все полагаются на неявные ссылки в своем коде, даже вы. Каждый раз, когда вы объявляете переменную As String или As Long , или используете функцию, такую как Left , Split , или Trim , вы полагаетесь на неявную ссылку на библиотеку VBA. Даже ваш пример кода включает две неявные ссылки. Чтобы избежать их xlDown и xlToRight должны быть записаны как Excel.xlDown и Excel.xlToRight .

4. Где вы ошибаетесь во втором пункте, это утверждение, которое Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy может быть истолковано как принадлежащее Word. Этого не могло произойти. Однако, если был активирован другой лист в рабочей книге, диапазон может быть взят не с того листа. Я согласен, что хорошей практикой является конкретизация рабочей книги / рабочего листа, на который ссылаются. Вы просто использовали неправильный вывод, чтобы проиллюстрировать свою точку зрения.

Ответ №2:

Проблемы, которые вы видите, вероятно, вызваны использованием буфера обмена. При копировании и вставке больших элементов, например таблиц данных, диаграмм, может возникнуть задержка.

Когда вы используете буфер обмена, вы передаете некоторый контроль ОС. VBA включает функцию, DoEvents которая передает управление операционной системе. Затем управление возвращается после того, как операционная система завершит обработку событий в своей очереди. Добавляя это после каждого копирования / вставки, это должно позволить наверстать упущенное.

Вы также можете немного сократить использование буфера обмена, установив значения для «Организация» и «Пациенты мужского пола» напрямую.

 Sub CreateBasicWordReport()
   Dim WdApp As Word.Application
   Dim wdDoc As Word.Document
   Dim SaveName As String
   Dim FileExt As String
   Dim LstObj1 As ListObject
   Dim MaxValue As Integer
   Dim FilterValue As Integer
   Dim Organisation As String
   Dim Rng As Range
   Dim WS As Worksheet
   
   Application.DisplayAlerts = False
   Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
   
   MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
    
   FilterValue = MaxValue
    
   Set WdApp = CreateObject("Word.Application")
   Do Until FilterValue = 0
    
      Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
      Sheets("Sheet1").Select
   
      With WdApp
         .Visible = True
         .Activate
         'create new document and assign to object variable
         Set wdDoc = .Documents.Add("C:UsersdavidDocumentsCustom Office TemplatesIBD Registry Quarterly Report Template2.dotx")
         'now mostly finished with WdApp as from here wdDoc is used
      End With
      
      ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
      Range("F11").Select
              
      Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
    
      wdDoc.Bookmarks("TableLocation").Range.Paste
      DoEvents
      
      For Each Row In Range("Table1[#All]").Rows
         If Row.EntireRow.Hidden = False Then
            If Rng Is Nothing Then Set Rng = Row
            Set Rng = Union(Row, Rng)
         End If
      Next Row
      Set WS = Sheets("Static")
      Rng.Copy Destination:=WS.Range("A1")
      Application.CutCopyMode = False
      DoEvents

      Organisation = WS.Range("D2").Value
      wdDoc.Bookmarks("Organisation").Range.Text = Organisation
    
      wdDoc.Bookmarks("MalePatients").Range.Text = WS.Range("F2").Text
    
      Chart2.ChartArea.Copy
      wdDoc.Bookmarks("ChartLocation").Range.Paste
      DoEvents
      Application.CutCopyMode = False
    
      If CLng(WdApp.Version) <= 11 Then
         FileExt = ".doc"
      Else
         FileExt = ".docx"
      End If
    
      SaveName = Environ("UserProfile") amp; "DesktopIBD Registry Quarterly Report for " amp; _
         Organisation amp; " " amp; _
         Format(Now, "yyyy-mm-dd hh-mm-ss")
      SaveNamePDF = SaveName amp; ".pdf"
      SaveName = SaveName amp; FileExt
      
      If CLng(WdApp.Version) <= 12 Then
         wdDoc.SaveAs SaveName
      Else
         wdDoc.SaveAs2 SaveName
      End If
    
      wdDoc.ExportAsFixedFormat _
         OutputFileName:=SaveNamePDF, _
         ExportFormat:=wdExportFormatPDF _

         wdDoc.Close

         FilterValue = FilterValue - 1
         
         Sheets("Static").Delete
         
         Application.DisplayAlerts = True
      
   Loop

   WdApp.Quit
    
   Set WdApp = Nothing
    
End Sub

Вопрос:

Ответ №1:

Комментарии:

Ответ №2:

Вам также может понравиться

Второй поток запускается только после завершения первого потока вместо параллельного запуска

Когда использовать встраивание и ссылки в MongoDB

Вычисление Numba Cuda, по-видимому, выполняется медленнее, чем последовательный запуск. Сделал ли я очевидные ошибки?