vb6 word 2002 合并单元格 |
您所在的位置：网站首页 › excel合并文档vba › vb6 word 2002 合并单元格 |
vb6 word 2002 合并单元格
VBA实践+把大纲级别分明的word文档转换成横向从属结构excel表格
有一个比较规范的word文档，各级标题大纲级别分明，现在要按照各段落的大纲级别转换到excel中，表格是横向从属结构的，如最左侧的是一级大纲的内容，往右侧依次对应是二级大纲，三级大纲……左侧要根据其右侧对应的内容行数的多少进行单元格合并。整体要求如下图所示。 
之前写了一个文章，通过手动半自动的方法实现，步骤较多，操作比较麻烦。文章链接如下： 阿德：如何快速把层级分明的word文档转换成横向从属结构的excel表格zhuanlan.zhihu.com
现在通过VBA代码的方式，一键实现上述的所有过程。代码包括一个主程序、两个子过程和一个自定义函数。主程序“WordToExcel”会调用两个子过程。“RngToExcel(Rng As Range)”子过程完成word内容转换到excel中；“标题列单元格合并(ExSheet As Worksheet)”子过程完成excel中单元格的合并，它会调用自定义函数“获得区域内非空单元格行号(Orange As Excel.Range)”来帮助处理单元格合并。 代码在Word VBA中运行，在运行前需要引用excel的对象库，操作如下图所示。 
WORD VBA引用EXCEL对象库
代码如下： Option Explicit '声明全局变量 Dim ExBook As Excel.Workbook, ExSheet1 As Worksheet, iRow As Long Sub WordToExcel() '这是主程序 '根据内容的大纲级别转换到excel表格中，形成一个左右结构的表格。 iRow = 1 '初始化行号为1 Set ExBook = Workbooks.Add '新建一个excel工作簿 ExBook.Application.Visible = True '工作簿可见 Set ExSheet1 = ExBook.Worksheets(1) '把工作簿中的第一个工作表赋值到ExSheet1，备用。 Dim Par As Paragraph, Rng As Range Dim ParCount As Long, i As Long ParCount = ThisDocument.Paragraphs.Count '文档段落总数 For i = 1 To ParCount Set Par = ThisDocument.Paragraphs(i) '从文档的第一个标题段开始处理，如果之前有正文内容，则忽略了。 If Par.OutlineLevel < wdOutlineLevelBodyText Then Par.Range.Select '选中标题段落 Set Rng = Selection.Bookmarks("headinglevel").Range '选择该标题段落及其所辖内容 Call RngToExcel(Rng) '调用子过程RngToExcel End If i = i + Rng.Paragraphs.Count - 1 '考到next语句会加1，所以这些减去1 Next '合并单元格 Call 标题列单元格合并(ExSheet1) ExBook.SaveAs "F:userdataDesktoptest.xlsx" '保存工作簿 ExBook.Close '关闭工作簿 Set ExBook = Nothing: Set ExSheet1 = Nothing MsgBox "处理完成！" End Sub Sub RngToExcel(Rng As Range) '这是一个子过程，完成word内容转换到excel中 Dim Par1 As Paragraph, nPar As Paragraph, Rng1 As Range Dim iColumn As Long, i As Long, iParCount As Long '处理Rng的第一段 Set Par1 = Rng.Paragraphs(1) iColumn = Par1.OutlineLevel ExSheet1.Cells(iRow, iColumn) = Par1.Range iParCount = Rng.Paragraphs.Count '取得Rng的段落总数 If iParCount >= 2 Then '如果Rng的段落总数大于2，处理Rng的剩余段 For i = 2 To iParCount Set nPar = Rng.Paragraphs(i) '取得Rng中第2段开始的一段 If nPar.OutlineLevel < wdOutlineLevelBodyText Then '如果该段也是标题段 nPar.Range.Select '则选中它 Set Rng1 = Selection.Bookmarks("headinglevel").Range '取得该标题段所控制范围 i = i + Rng1.Paragraphs.Count - 1 '考到next语句会加1，所以这些减去1 Call RngToExcel(Rng1) '递归处理 Else '如果是正文文本，则下一列填写 ExSheet1.Cells(iRow, iColumn + 1) = nPar.Range iRow = iRow + 1 '行号+1 End If Next Else '只有一段时，是标题段，直接行号加1 iRow = iRow + 1 End If End Sub Sub 标题列单元格合并(ExSheet As Worksheet) '这是一个子过程，完成excel中单元格的合并 '要确保usedrange是从A1开始的,否则usdrange的行号与表格的行号不一致 '几个相邻的具有从属关系的标题列下上合并，但各层次标题单元格间已经对齐到开始第一格，不错位 Dim Orange As Excel.Range Dim a() As Long, i&, j&, m&, n&, k& With ExSheet m = .UsedRange.Rows.Count n = .UsedRange.Columns.Count - 1 '要合并的最后一列 '开始处理 For k = n To 1 Step -1 Set Orange = .Range(.Cells(1, 1), .Cells(m, k)) '定义列的范围，用于分割区域 a = 获得区域内非空单元格行号(Orange) i = UBound(a) For j = 1 To i If .Cells(a(j), k) "" Then '有内容时合并 If j < i Then .Range(.Cells(a(j), k), .Cells(a(j + 1) - 1, k)).Merge Else .Range(.Cells(a(j), k), .Cells(m, k)).Merge End If End If Next j Next k End With End Sub Function 获得区域内非空单元格行号(Orange As Excel.Range) '不依赖于具体的区域范围 Dim i&, k& Dim a() As Long Dim oRow As Excel.Range i = 0 '计算区域内非空行的数量 For Each oRow In Orange.Rows If WorksheetFunction.CountA(oRow) > 0 Then i = i + 1 End If Next '用数组记录区域内非空行号 ReDim a(1 To i) '重定义数组 k = 1 For Each oRow In Orange.Rows If WorksheetFunction.CountA(oRow) > 0 Then a(k) = oRow.Row k = k + 1 End If Next 获得区域内非空单元格行号 = a End Function代码运行演示 知乎视频www.zhihu.com想要学习更多有关VBA的实用知识，可以看电子书 |
【本文地址】
今日新闻 |
推荐新闻 |