在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