|
|
Sub 拆分为word文档()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long
Dim br(), cr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:e" & r)
End With
ReDim br(1 To 100000, 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If ar(i, 5) <> "" Then
rr = Split(ar(i, 5), Chr(10))
For s = 0 To UBound(rr)
If rr(s) <> "" Then
n = n + 1
For j = 1 To 4
br(n, j) = ar(i, j)
Next j
br(n, 5) = rr(s)
If Not d.exists(rr(s)) Then Set d(rr(s)) = CreateObject("scripting.dictionary")
d(rr(s))(n) = ""
End If
Next s
End If
Next i
Dim wdApp As Object
Set wdApp = CreateObject("Word.Application") '新建Word对象
lj = ThisWorkbook.Path & "\"
wdApp.Visible = True
For Each k In d.keys
m = 0
ReDim cr(1 To d(k).Count, 1 To UBound(ar, 2))
For Each kk In d(k).keys
m = m + 1
For j = 2 To UBound(br, 2)
cr(m, j) = br(kk, j)
Next j
cr(m, 1) = m
Next kk
wdApp.Documents.Add ''新建一个word文档
With wdApp
.Selection.TypeParagraph '''光标下移一行
.ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=m + 1, NumColumns:=5 '插入n + 1x4表格
End With '''新建一个word表格
Set wdBG = wdApp.ActiveDocument.Tables(1) '创建表格对象
With wdBG '表格写入文本
If .Style <> "网格型" Then
.Style = "网格型"
End If
.Cell(1, 1) = "序号"
.Cell(1, 2) = "任务"
.Cell(1, 3) = "时间"
.Cell(1, 4) = "进展"
.Cell(1, 5) = "责任单位"
With .Range '表格
.Font.Bold = True字型加粗
.Font.Size = 12 '字号
.Font.Name = "宋体" '字体
.ParagraphFormat.Alignment = 1 '"'0左对齐1居中
End With
For i = 1 To m
For j = 1 To 5
.Cell(i + 1, j).Range.Text = cr(i, j) ''wdWORD.ActiveDocument.Tables(tt)
Next j
Next i
End With
wdApp.ActiveDocument.SaveAs Filename:=lj & k & ".docx"
wdApp.ActiveDocument.Close
Next k
wdApp.Quit ''关闭新建文档窗口
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-10-17 17:25
楼主
