如何将固定格式的word文档快速转为表格形式？

kangkang008 · 发表于 2024-7-31 11:01

本人经常有固定格式的文档，需要同时转换为表格形式（word表格或者excel表格都可以）。由于有多页文字，如果一个个复制粘贴，耗时较长。请教各位看看有没有快速办法将word文档格式转为表格形式？谢谢

413191246se · 发表于 2024-7-31 21:48

楼主，你附件第二段落缺少“督导单位”，请将真实的附件上传（当然为了保密，可以将单位虚拟一下）。

kangkang008 · 发表于 2024-8-6 16:04

413191246se 发表于 2024-7-31 21:48
楼主，你附件第二段落缺少“督导单位”，请将真实的附件上传（当然为了保密，可以将单位虚拟一下）。

麻烦你按统一没有“督导单位”的来操作，谢谢。期待你的解决！

413191246se · 发表于 2024-8-7 12:56

* 楼主，请将代码复制到空白文档后，全选，剪切，再粘贴到 VBE 中，这样不会乱码。
* 基本达到目的，但并非完美！未做字段检查，如果文档不规范，将会出错，请自行检查！
* 表格是 Word 格式并未保存，也可以将其复制到 Excel 中保存。

Sub a0807_Txt2Tab()
Const s As String = "^13[一二三四五六七八九十百千零〇○Oo0０Ｏｏ]@、*^13"
Dim doc As Document, i As Paragraph, j&, k&, r As Range, n&, oLines&, c As Cell
Set doc = ActiveDocument
For Each i In doc.Paragraphs
With i.Range
If Asc(.Text) = 13 Then .Delete
End With
Next
With doc.Content
.InsertParagraphBefore
.InsertParagraphAfter
With .Find
.Execute "(", , , 0, , , , , , "（", 2
.Execute ")", , , 0, , , , , , "）", 2
.Execute ":", , , 0, , , , , , "：", 2
End With
End With
With Selection
.WholeStory
.Font.ColorIndex = wdAuto
.HomeKey 6
With .Find
.ClearFormatting
.Text = "^13整改措施?^13"
.Replacement.Text = ""
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.MoveStart
Do While .Next(4, 1) Like "（*"
.Paragraphs(1).Range.Characters.Last.Text = "`"
Loop
.Paragraphs(1).Range.Font.Color = wdColorPink
.Start = .End
End With
Loop
End With
.Move 4
.EndKey 6, 1
.Delete
.HomeKey 6
With .Find
.ClearFormatting
.Text = s
.Replacement.Text = ""
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.MoveStart
.InsertBefore Text:="问题："
.Font.Color = wdColorRed
If j = 0 Then
j = 1
.HomeKey 6, 1
.Delete
End If
.Start = .End
End With
Loop
End With
k = doc.Paragraphs.Count
oLines = k / 5
.EndKey 6
doc.Tables.Add Range:=Selection.Range, NumRows:=oLines, NumColumns:= _
5, DefaultTableBehavior:=wdWord9TableBehavior
For Each c In doc.Tables(1).Range.Cells
With c.Range
n = n + 1
c.Range.Text = doc.Paragraphs(n).Range.Text
End With
Next
End With
doc.Tables(1).Range.Cut
doc.Close 0
Documents.Add.Content.Paste
With ActiveDocument.Tables(1)
With .Columns(1)
.Select
Selection.Find.Execute "问题：", , , 0, , , , , , "", 2
End With
With .Columns(2)
.Select
Selection.Find.Execute "责任单位：", , , 0, , , , , , "", 2
End With
With .Columns(3)
.Select
Selection.Find.Execute "整改目标：", , , 0, , , , , , "", 2
End With
With .Columns(4)
.Select
Selection.Find.Execute "整改时限：", , , 0, , , , , , "", 2
End With
With .Columns(5)
.Select
Selection.Find.Execute "`", , , 0, , , , , , "^p", 2
End With
With .Columns(5)
.Select
Selection.Find.Execute "整改措施：^p", , , 0, , , , , , "", 2
End With
.Columns(1).Select
Selection.InsertColumns
n = 0
For Each c In Selection.Cells
n = n + 1
c.Range.Text = n
Next
.Rows(1).Select
Selection.InsertRows
With .Rows(1)
.Cells(1).Range = "序号"
.Cells(2).Range = "问题"
.Cells(3).Range = "责任单位"
.Cells(4).Range = "整改目标"
.Cells(5).Range = "整改时限"
.Cells(6).Range = "整改措施"
End With
.AutoFitBehavior (wdAutoFitContent)
.Select
.AutoFitBehavior (wdAutoFitWindow)
'delete-space
For Each c In .Range.Cells
For Each i In c.Range.Paragraphs
If Asc(i.Range) = 13 And Len(i.Range) = 1 Then i.Range.Delete
Next
With c.Range.Paragraphs
If .Count > 1 And Len(.Last.Range) = 2 Then .Last.Previous.Range.Characters.Last.Delete
End With
Next
.Columns(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
'head-bold
.Cell(1, 1).Select
With Selection
.SelectRow
.Font.Bold = True
.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
With .Range.Font
.Size = 10.5
.ColorIndex = wdAuto
End With
.Rows.Alignment = wdAlignRowCenter
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
Selection.HomeKey 6
MsgBox "Complete!", 0 + 48
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 如何将固定格式的word文档快速转为表格形式？