Создать таблицы в слове для каждой строки в листе Excel

Question

Я создаю текстовый отчет, и все мои данные находятся на листе Excel. Лист такой:

ID Name1 Name2 Name3 Name4
1  blah  blah  blah  blah
2  blah  blah  blah  blah
3  blah  blah  blah  blah

И я хочу, чтобы в документе word была одна таблица для каждой строки рабочего листа, например:

*-------*----*
|ID     |1   |
|Name1: |blah|
|Name2: |blah|
|Name3: |blah|
|Name4: |blah|
*-------*----*

*-------*----*
|ID     |2   |
|Name1: |blah|
|Name2: |blah|
|Name3: |blah|
|Name4: |blah|
*-------*----*

etc

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

Приветствуются любые идеи / указания о том, как это можно сделать!

Answer 1

Следующий код может вам помочь. При использовании кода убедитесь в следующем

1. Для приведенного ниже кода необходимы данные в листе 1.

2. Код работает путем копирования данных из Листа 1 в Лист 2, поэтому убедитесь, что у вас нет важных данных в Листе 2

   Sub CopyRowToRC()
   Sheet2.Range("A:B").Clear
   i = 1
   j = 2
   Application.ScreenUpdating = False
   With Sheet1
   LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   For i = 1 To LastRow
   
   With Sheet2
   LastRows = .Cells(.Rows.Count, "A").End(xlUp).Row
   If i > 1 Then
   LastRows = LastRows + 2
   End If
   End With
   
   If j <= LastRow Then
   Sheet1.Rows(1).SpecialCells(xlCellTypeConstants).Copy
   Sheet2.Range("A" & LastRows).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=True
   Sheet1.Rows(j).SpecialCells(xlCellTypeConstants).Copy
   Sheet2.Range("B" & LastRows).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=True
   j = j + 1
   End If
   Next
   Sheet2.Activate
   Application.ScreenUpdating = False
   WordUp
   End Sub
   
   
   Sub WordUp()
   On Error Resume Next
   Dim WdObj As Object, fname As String
   fname = "File Name"
   Set WdObj = CreateObject("Word.Application")
   WdObj.Visible = True
   
   With Sheet2
   LastRows = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With
   
   Sheet2.Range("A1:B" & LastRows).Copy
   
   WdObj.documents.Add
   WdObj.Selection.PasteExcelTable False, False, False
   With WdObj
       .ActiveDocument.Close
       .Quit
   End With
   Set WdObj = Nothing
   Sheet2.Range("A:B").Clear
   Sheet1.Activate
   Application.ScreenUpdating = True
   End Sub