VBA实现从指定文件夹批量抓取Word文档内容并整理（上）

任务场景：

1. 文件夹内已经汇总了几十上百篇Doc/Docx文档，可能是各部门的总结，可能是工会入会申请，或者其它半格式化（毕竟不是表格）内容，如果没有VBA帮忙，你就要挨个打开，之后copy-n-paste里面的特定内容到你的Excel表里；
2. 你在网上白嫖了一段代码，但是发现能用是能用，但是摘出来的信息有几个突出问题：1）到处夹空格、夹不可见符号；2）因为Word排版的关系，抓到Excel里面有很多空单元格；3）抓出来的同类信息不在同一列（举例来说，同是一份俱乐部申请，A的“自我介绍“部分写1段，B的“自我介绍”部分写了5段，抓出来肯定占的单元格数量不同）。

配料和思路

这次结合我工作中遇到的问题先解决1、2里面的主要部分即：1.文件抓取；2.基本清理（去除字符串内空格）；3.对导出到Excel表里的内容进行再排序，去掉因为排版问题造成的空单元格。水平有限，代码相当冗长，但好处在于用到的知识点少，操作简单粗暴合适和我水平类似的非IT专业人士。

精确抓取特定内容的放在（下）里面介绍。

1. 需要用到的技能

• 文件系统操作：从Excel VBA里面打开(world.application.Document.Open)、关闭Word文档、判断文件夹内文件的个数（文件指针.Files.Count）
• 字符串操作： 清理非打印字符（clean）、消除两端空格（trim）、后续还要用到查找（InStr）、截取（Left）等
• 判断和循环：基础的If判断，Do While循环嵌套使用
• Excel VBA里的单元格操作：对单元格里内容的删改

2. 流程（建议结合代码看）

1. 定义各种变量，告诉电脑给我在内存里准备好位置，我要出Excel外到Windows里面找文件，对他们进行操作了
2. 生成Scripting FSO(即“为了把文件里的内容写到别的地方而设置的文件系统对象”）
3. 把文件所在的文件夹地址丢给电脑，建立FP(文件指针），这时候电脑已经准备好对目标文件夹里的文件“动手”了
4. 与此同时，把要写入的表格的内容框架搭建好，这里用的是数组（arr）形式，数组的第一行格列是表头。行数由目标文件夹里的文件数决定，列数由你自己决定（通常就是你想抓Word文档里多少次换行前的内容）。
5. For each循环，开始逐一查看文件夹里的文件
6. IF判断是否为doc/docx文档，是的话就打开文件，开始在文档里逐行读取再写入到数组里。word里面每一次换行（.Paragraph(行数））就往数组里向右写一个格，读好写好关闭文件。
7. 遍历完文件夹内所有文件以后退出For each循环……假设一共读了10个文件，每个文件读前20列，那么这个数组的的size就是11行（带“表头”）20列
8. 回到我们的Excel表，用UBound取出上面用的数组在两个维度上的最大值（比如11行、20列就是11、20）在工作表里划出一片区域。然后把数组里存的内容写到这个区域里面来。至此，最基本的抓取已经结束，代码见 Text_Capturing()部分**
9. 对特定列里面的字符串去空格（详见本博客另一篇讲邮件中空格专杀的文章），代码见Space_Killer（）部分
   10.检查表格里的空单元格：1.如果一个单元格式空的但它右边的非空，就把右边的挪过来（内容赋值进来，再从原位置删掉）；2.如果一个单元格和它右边的都是空的，就把再右边一个里的内容放进来…，大部分情况下很少有连续空三个的，代码见Empty_Cell_Killer（）部分

3. 结果

几十个Word文档内前20多个换行里的内容别抓到了Excel里，而且没有因为排版空行造成的空单元格。

假设我们抓的是几十位老师的教案信息，那么现在就差把他们长度不一的“摘要”、“教学目标”、“适用课程”等信息合并整理了到专门的列里面去了。

咱们下回分解！

上代码（小白级别，所以注释多且冗长）

第一段，抓取部分主体

Sub Text_Capturing()

    Rem 先进行系统层面上的准备
    Dim fso 'File System Obeject文件系统对象，要执行操作，先要在内存里生成一个任务对象
    Dim fp  'File Pointer文件指针。在新建的fso基础上进一步为其制定工作表所在路径
    Dim f_num '为了最后给用户报数用
    
    Rem 然后进行Office套件层面上的准备
    Dim wd  '定义Word程序对象，说白了就是告诉系统要用Word这个应用了，请加载到内存里
    Dim f   '在Word程序对象基础上创建文件对象，每遍历到一个doc/docx就是一个f
    Dim fname As String
    
    Rem 最后定义Excel内部要用到的变量
    Dim arr '数组对象，用数组的方式去写range
    Dim n As Long
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("操作界面")
    Path = ws.Cells(8, 2) & "\" '即操作界面里请用户输入文件夹地址的那个地方
    Debug.Print Path
    

    
    Set fso = CreateObject("scripting.filesystemobject")
    Set fp = fso.getfolder(Path)
    f_num = fp.Files.Count
    
    ReDim arr(1 To f_num + 1, 1 To 24) '行数= 1到文件个数，列数=看要摘多少行内容了
    Rem 注意这里数组中表示行数部分要加1，才能容纳表头，如不加1，回导致下标越界
    
    arr(1, 1) = "被抓取文件名": arr(1, 2) = "案例编号与出版日期": arr(1, 3) = "第1行"
    arr(1, 4) = "第2行": arr(1, 5) = "第3行": arr(1, 6) = "第4行": arr(1, 7) = "第5行"
    arr(1, 8) = "第6行": arr(1, 9) = "第7行": arr(1, 10) = "第8行": arr(1, 11) = "第9行"
    arr(1, 12) = "第10行": arr(1, 13) = "第11行": arr(1, 14) = "第12行"
    arr(1, 15) = "第13行": arr(1, 16) = "第14行": arr(1, 17) = "第15行"
    arr(1, 18) = "第16行