Excelシート内の各行に単語でテーブルを作成

Question

私は単語レポートを作成しています。私のすべてのデータはExcelシートにあります。

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

そして、私が欲しいのは、このようなワークシートの行ごとに一つのテーブルを持つように、ワード文書である： シートは、このようなものです

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

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

etc 

私はこれがあるべきだと思いますかなりストレートですが、残念ながら私はこれまでに何かをしたことはありません。

どうすればいいですか？

Answer 1

次のコードを参考にしてください。コードを使用している間は、次のことを確認してください。

1. 以下のコードは、データがSheet1にある必要があります。

2. コードので、あなたは私の知る限り、これは単純ではないが知っているようにSheet2の

   で重要なデータ

   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