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

以下代码可以为您提供帮助。使用代码时请确保以下

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

代码通过将Sheet1中的数据复制到Sheet 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

在Excel中为excel表中的每一行创建表

1 个答案: