在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 

我认为这应该是非常直截了当，但不幸的是，我从未做过这样的事情。

欢迎任何有关如何完成ti的想法/指示！

Answer 1

以下代码可以帮助您。在使用代码时，请确保以下内容

1. 以下代码需要数据在Sheet1中。

2. 代码的工作原理是在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