vb6 word 2002 合并单元格_VBA实践+把大纲级别分明的word文档转换成横向从属结构excel表格...

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的实用知识，可以看电子书