|
|
Sub lx()
Dim ar, i%, j%, m%, s%, wd As Object, w As Object, w1 As Object
ar = Sheet1.Range("a2:h" & Range("c2").End(xlDown).Row)
For i = 1 To UBound(ar) - 1
If ar(i, 1) <> "" Then
s = ar(i, 1)
If ar(i + 1, 1) = "" Then ar(i + 1, 1) = s
End If
Next i
Set wd = CreateObject("word.application")
wd.Visible = True
Set w = wd.documents.Open(ThisWorkbook.Path & "\1.docx")
For m = 1 To ar(UBound(ar), 1)
Set w1 = wd.documents.Add
w.Range.Copy
w1.Range.Paste
For i = 1 To UBound(ar)
If ar(i, 1) = m Then
k = k + 1
For j = 1 To UBound(ar, 2)
ar(k, j) = ar(i, j)
Next j
End If
Next i
With w1.tables(1)
.cell(1, 2).Range.Text = ar(1, 3) & Chr(7)
.cell(1, 4).Range.Text = ar(1, 5)
.cell(2, 2).Range.Text = ar(1, 6)
.cell(1, 6).Range.Text = Mid(ar(1, 6), 7, 8)
.cell(2, 4).Range.Text = k
.cell(3, 2).Range.Text = ar(1, 8)
For i = 1 To k
For j = 1 To 2
.cell(i + 4, j).Range.Text = ar(i, j + 2)
Next j
.cell(i + 4, 3).Range.Text = ar(i, 6)
Next i
End With
w1.SaveAs (ThisWorkbook.Path & "\" & ar(1, 3) & ".docx")
w1.Close
k = 0
Next m
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2021-3-25 12:02
楼主
