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

d4f8c0cca06645269d41e32ff985adb2.png

VBA实践+把大纲级别分明的word文档转换成横向从属结构excel表格

有一个比较规范的word文档,各级标题大纲级别分明,现在要按照各段落的大纲级别转换到excel中,表格是横向从属结构的,如最左侧的是一级大纲的内容,往右侧依次对应是二级大纲,三级大纲……左侧要根据其右侧对应的内容行数的多少进行单元格合并。整体要求如下图所示。

02405fc9fc3e8275bc328be74bb47df6.png

之前写了一个文章,通过手动半自动的方法实现,步骤较多,操作比较麻烦。文章链接如下:

阿德:如何快速把层级分明的word文档转换成横向从属结构的excel表格​zhuanlan.zhihu.com
babb97c7933235fa07a9d5a7ccccf547.png

现在通过VBA代码的方式,一键实现上述的所有过程。代码包括一个主程序、两个子过程和一个自定义函数。主程序“WordToExcel”会调用两个子过程。“RngToExcel(Rng As Range)”子过程完成word内容转换到excel中;“标题列单元格合并(ExSheet As Worksheet)”子过程完成excel中单元格的合并,它会调用自定义函数“获得区域内非空单元格行号(Orange As Excel.Range)”来帮助处理单元格合并。

代码在Word VBA中运行,在运行前需要引用excel的对象库,操作如下图所示。

9654e0e194b7839976b007fca5cfe49e.png
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的实用知识,可以看电子书

已标记关键词 清除标记
表情包
插入表情
评论将由博主筛选后显示,对所有人可见 | 还能输入1000个字符
相关推荐
程序员的必经之路! 【限时优惠】 现在下单,还享四重好礼: 1、教学课件免费下载 2、课程案例代码免费下载 3、专属VIP学员群免费答疑 4、下单还送800元编程大礼包 【超实用课程内容】  根据《2019-2020年中国开发者调查报告》显示,超83%的开发者都在使用MySQL数据库。使用量大同时,掌握MySQL早已是运维、DBA的必备技能,甚至部分IT开发岗位也要求对数据库使用和原理有深入的了解和掌握。 学习编程,你可能会犹豫选择 C++ 还是 Java;入门数据科学,你可能会纠结于选择 Python 还是 R;但无论如何, MySQL 都是 IT 从业人员不可或缺的技能!   套餐中一共包含2门MySQL数据库必学的核心课程(共98课时)   课程1:《MySQL数据库从入门到实战应用》   课程2:《高性能MySQL实战课》   【哪些人适合学习这门课程?】  1)平时只接触了语言基础,并未学习任何数据库知识的人;  2)对MySQL掌握程度薄弱的人,课程可以让你更好发挥MySQL最佳性能; 3)想修炼更好的MySQL内功,工作中遇到高并发场景可以游刃有余; 4)被面试官打破沙锅问到底的问题问到怀疑人生的应聘者。 【课程主要讲哪些内容?】 课程一:《MySQL数据库从入门到实战应用》 主要从基础篇,SQL语言篇、MySQL进阶篇三个角度展开讲解,帮助大家更加高效的管理MySQL数据库。 课程二:《高性能MySQL实战课》主要从高可用篇、MySQL8.0新特性篇,性能优化篇,面试篇四个角度展开讲解,帮助大家发挥MySQL的最佳性能的优化方法,掌握如何处理海量业务数据和高并发请求 【你能收获到什么?】  1.基础再提高,针对MySQL核心知识点学透,用对; 2.能力再提高,日常工作中的代码换新貌,不怕问题; 3.面试再加分,巴不得面试官打破沙锅问到底,竞争力MAX。 【课程如何观看?】  1、登录CSDN学院 APP 在我的课程中进行学习; 2、移动端:CSDN 学院APP(注意不是CSDN APP哦)  本课程为录播课,课程永久有效观看时长 【资料开放】 课件、课程案例代码完全开放给你,你可以根据所学知识,自行修改、优化。  下载方式:电脑登录课程观看页面,点击右侧课件,可进行课程资料的打包下载。
<p> <strong><span style="font-size:16px;color:#003399;">手工测试中遇到的坑 你踩过几个?</span></strong><strong><span style="font-size:16px;color:#003399;"></span></strong> </p> <p> <br /> </p> <p> <img src="https://img-bss.csdnimg.cn/202012171208356126.png" alt="" /> </p> <p> <br /> </p> <p> <br /> </p> <p> <strong><span style="font-size:16px;color:#003399;">解锁自动化测试技能 打破手工测试局限</span></strong> </p> <p> <br /> </p> <p> <span style="font-size:14px;">自动化测试是测试工作的一部分,是对手工测试的一种补充。自动化测试是相对手工测试而存在的,通过所开发</span><span style="font-size:14px;">的软件测试工具、脚本等来实现,具有良好的可操作性、可重复使用和高效率等特点。</span> </p> <p> <span style="font-size:14px;"><br /> </span> </p> <p> <span style="font-size:14px;"><img src="https://img-bss.csdnimg.cn/202012171212024924.png" alt="" /><br /> </span> </p> <p> <span style="font-size:14px;"><br /> </span> </p> <p> <br /> </p> <p> <br /> </p> <p> <span style="font-size:16px;color:#003399;"><strong>Python自动化测试</strong></span> </p> <p> <span style="font-size:14px;"><strong><span style="font-size:16px;color:#003399;">系统教学+实战分析 简单易上手</span></strong><strong><span style="font-size:16px;color:#003399;"></span></strong><strong><span style="font-size:16px;color:#003399;"></span></strong><br /> </span> </p> <p> <span style="font-size:14px;"><br /> </span> </p> <p> <span style="font-size:14px;">课程使用的是语法简洁、提供丰富的测试库和框架的Python语言,并从测试人员的角度,梳理当前最热门的自动化测试框架和常用库,并通过实战,带你快速建立自动化测试技术体系,让测试工作更高效!<br /> </span> </p> <p> <span style="font-size:14px;"><br /> </span> </p> <p> <span style="font-size:14px;"><img src="https://img-bss.csdnimg.cn/202012171223546601.png" alt="" /><br /> </span> </p> <p> <br /> </p> <p> <br /> </p> <p> <strong><span style="font-size:16px;color:#003399;">3个项目实战</span></strong> </p> <p> <strong><span style="font-size:16px;color:#003399;">全程手敲代码演示 听得懂 更要会用</span></strong><strong><span style="font-size:16px;color:#003399;"></span></strong> </p> <p> <br /> </p> <p> <img src="https://img-bss.csdnimg.cn/202012171224069333.png" alt="" /> </p> <p> <br /> </p> <p> <br /> </p> <p> <strong><span style="font-size:16px;color:#003399;">3大购课福利</span></strong> </p> <p> <br /> </p> <p> <img src="https://img-bss.csdnimg.cn/202012180149359103.png" alt="" /> </p>
©️2020 CSDN 皮肤主题: 数字20 设计师:CSDN官方博客 返回首页