常用代码

VBA常用代码（自定义函数）

相比自定义带参数的sub过程来说，自定义函数在VBA编程时更为常见一些。
相信你对函数不陌生吧，日常办公时，或多或少都会涉及一些常用函数，比如：求和函数SUM()；比如求平均值的函数AVERAGE()等等。这些我们统称为EXCEL的内置函数，也就是自带的函数，但是如果想实现的功能，现有的内置函数达不到，怎么办？那就只能自己定义函数了，这样的函数又叫做“自定义函数”。
所以，它们都属于“函数”这个大家庭，只是出身有所不同而已。
使用函数时，感觉最为方便就是随便打开一个表格都可以用，不用局限于某个表格内或某个文件里。这就是函数的最大好处，即，它具有通用性。就如俗话说的：我是一块砖，哪里需要哪里搬。这种通用性，在程序编写的过程中，好处显而易见，写代码的效率因此能得到大大的提升。为啥？因为你不用重新“造轮子”，直接调用以前写好的函数就OK了。这样一来，代码也很简洁，逻辑一目了然。

我一直觉得编程写代码最关键最重要的是梳理清楚逻辑和思路，也就是若想完成这个事，应该怎么做，注意不是泛泛的说说而已。
而是要分解到每一步，每一个可执行的最小单元才行。什么是可执行的最小单元？如何判断是不是可执行的最小单元？标准就是：这个单元能不能写成一个函数，如果可以，那就是，如果不行，那就还有继续拆解的空间。
所以，发现没，做事思路清楚了，最小单元找到了，接下来要做的只是逐一地将每个最小单元用代码写成一个个函数模块，下一步就是按照之前梳理的逻辑思路，串联在一起就OK了。
再复杂的编程，估计也离不开这个套路。

想要做的事情是，将多个WORD文件中的表头带有“优化前”字样的表格，提取到同一张EXCEL工作表中。怎么来做？
按照上述说法，将大的任务拆解到可执行的最小单元：
1、打开WORD格式的文件；
2、寻找WORD文件中的表头带有“优化前”字样的表格；
3、复制这个表格到工作表中

看似这样就可以了，但是在实际操作的时候，发现如果一次性将复制的表格汇总到同一张工作表中，存在一个问题，就是表头信息都一样，都每次还是要重复被复制粘贴，达不到想要的结果。
于是将上面的第3步再进行拆解：
1、先将每次复制的表格粘贴在不同工作表里；
2、用表格合并的办法，再把这些工作表汇总到同一个表中（同时要注意的是只保留一个表头信息），因为VBA主要用于EXCEL，所以同样的操作在EXCEL里实现，相对容易的多。
至此，上述任务就可以完成了。

以下是具体的代码，有助于直观地感受一下整个实现过程（需要注意的是上面提到的4个步骤，写到了2个自定义函数中，分别是readWord()和combine()）：

1
2
3
4
5
6
7
8
9
Sub GetinfofromWord() '主程序过程
Dim vFiles As Variant '定义文件类型
vFiles = Application.GetOpenFilename("*.docx,*.docx", , , , True) '打开指定格式文件所在的目录
Application.DisplayAlerts = False
On Error Resume Next
Application.DisplayAlerts = True '刷新屏幕
Call readWord
Call combine
End Sub

第一步：自定义函数：读取WORD文件中列头带有“优化前”字样的表格，并将内容复制到不同的工作表中。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Function readWord() 
Dim vFiles As Variant '定义文件类型
If VarType(vFiles) = vbBoolean Then
    Exit Function
End If  
Dim wordApp As Object
On Error Resume Next
Set wordApp = GetObject(, "word.application") '调用WORD程序
Set wordApp = CreateObject("word.application") '如果当前WORD程序未打开，则打开WORD应用程序
Dim doc As Object
Dim bFound As Boolean
Dim vFile As Variant
For Each vFile In vFiles
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    Set doc = wordApp.documents.Open(vFile)
    bFound = False
    Dim tbl As Object
    For Each tbl In doc.Tables
        If Left(tbl.Rows(1).Cells(2).Range.Text, 3) = "优化前" Then
            bFound = True
            tbl.Range.Copy
            With ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                curLogCell.Offset(0, 1).Value = .Name
                ThisWorkbook.Worksheets(SHEET_NAME_FIRST).Activate
                On Error Resume Next
                .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
            End With
        End If
    Next
    If bFound = False Then
        MsgBox "没找到对应表"
        curLogCell.Offset(0, 2).Value = curLogCell.Offset(0, 2).Value & "/" & "No Table"
    End If
    doc.Close
    Application.ScreenUpdating = True
Next
wordApp.Quit
End Function

第2步：将上述生成的不同工作表按照一定要求合并到同一张工作表中；

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Function combine() 
Dim iCNT As Integer
Dim destSht As Worksheet
Set destSht = Workbooks.Add.Worksheets(1)
Dim srcSht As Worksheet
On Error Resume Next
For Each srcSht In ThisWorkbook.Worksheets
    If srcSht.Rows(3).Cells(1) = "" Then
        srcSht.Rows(3).Delete
        srcSht.Columns("A:A").Copy Destination:=destSht.Cells(1, 1)
        srcSht.Columns("B:C").Copy _
        Destination:=destSht.Cells(1, destSht.Columns.Count).End(xlToLeft).Offset(0, 1)
    Else
        srcSht.Columns("A:A").Copy Destination:=destSht.Cells(1, 1)
        srcSht.Columns("B:C").Copy _
        Destination:=destSht.Cells(1, destSht.Columns.Count).End(xlToLeft).Offset(0, 1)
    End If
Next
End Function

同样地，在python编程中，也经常使用类似这样的编程方式：模块组合。
文章《python常用代码（EXCEL文件中图片提取）》中就有淋漓尽致的展现。