VBA，我的第一门语言（带你走进VBA的世界）

VBA是我正式学习的第一门计算机语言，也是一门我感情很深的计算机语言。它带我领略了编程的乐趣，让我相信一切皆有可能，一切皆可实现。它也给我带来的很多乐趣，很多工作机会。让我给你介绍一下它。

什么是VBA

百度百科

Visual Basic for Applications（VBA）是Visual
Basic的一种宏语言，是微软开发出来在其桌面应用程序中执行通用的自动化(OLE)任务的编程语言。主要能用来扩展Windows的应用程式功能，特别是Microsoft
Office软件。也可说是一种应用程式视觉化的Basic
脚本。该语言于1993年由微软公司开发的的应用程序共享一种通用的自动化语言——–Visual Basic For
Application(VBA)，实际上VBA是寄生于VB应用程序的版本。微软在1994年发行的Excel5.0版本中，即具备了VBA的宏功能。
由于微软Office软件的普及，人们常见的办公软件Office软件中的Word、Excel、Access、Powerpoint都可以利用VBA使这些软件的应用更高效率，例如：通过一段VBA代码，可以实现画面的切换；可以实现复杂逻辑的统计（比如从多个表中，自动生成按合同号来跟踪生产量、入库量、销售量、库存量的统计清单）等。

掌握了VBA，可以发挥以下作用：
- 规范用户的操作，控制用户的操作行为；
- 操作界面人性化，方便用户的操作；
- 多个步骤的手工操作通过执行VBA代码可以迅速的实现；
- 实现一些VB无法实现的功能。[1]
- 用VBA制做EXCEL登录系统。[2]
- 利用VBA可以Excel内轻松开发出功能强大的自动化程序。

VBA可以做到什么

1、基于Ribbon实现个性化的操作界面

• office2007开始，微软推出了一个新型的UI系统—Ribbon
  
  我们可以在word、ppt、excel等office组件中看到这个UI界面，提供用户一个快捷可视化的功能界面。
• 可以通过 Custom UI Editor For Microsoft Office等工具自定义Ribbon界面
  并通过VBA编写对界面按钮点击、输入、修改等操作时触发的事件，或者定义UI界面的动态变化规则，实现动态调整界面。

<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="itab" label="自动化工具">

        <group id="igrp1" label="数据源管理">
          <button 
    id="isource_clear" 
    label="清空数据源" 
    imageMso="_3DMaterialMetal" 
    size="large" 
    supertip="可用于清空所有订单表和招聘表中的信息" 
    onAction="isource_clear"/>
          <button 
    id="isource_input" 
    label="导入数据源" 
    imageMso="_3DMaterialPlastic" 
    size="large" 
    supertip="将选中文件《招聘订单信息一览表》和《招聘在途及外招信息一览表》中的信息导入到本工具对应的数据源中，累计添加." 
    onAction="isource_input"/>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

2、调动windows其他组件

• 对word和outlook的调用实现邮件自动发送

Sub eMailMergeWithAttchments(t As Worksheet)

Dim myDatarange As Range
Dim i As Long, j As Long, k As Long, l As Long
Dim ISectionsCount As Long
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim wWordApp As Object
Dim SrcDoc As Object
Dim oItem As Outlook.MailItem
Dim oAccount As Outlook.Account
Dim sMySubject As String, sMessage As String, sTitle As String
Dim RowNum As Long, ColNum As Integer
Dim TmpBody As String
Dim m As Integer, n As Integer, m1 As Integer, n1 As Integer
Dim VarName As String, RepName As String
Dim VarCol As Integer
Dim IsRight As Boolean
Dim MyPath As String
Dim StartVarCol As Integer
Dim PrePath As String
Dim StartText As String
Dim EndText As String
Dim Myrange01 As Object, Myrange02 As Object, Myrange03 As Object, FoundRange As Object
Dim isFind As Boolean
Dim RepStr As String, OldStr As String
Dim TmpFileName As String
Dim MyFile As New FileSystemObject
Dim SavePath As String
'
'Dim TestWRange As Word.Range

StartText = "<-|"
EndText = "|->"
'
'StartVarCol = 11
TmpFileName = "TmpHtmlDoc.htm"
'Set docSource = ActiveDocument


RowNum = t.Cells(12, 1).CurrentRegion.Rows.Count - 1
ColNum = t.Cells(12, 1).CurrentRegion.Columns.Count

If RowNum = 0 Then
    MsgBox "无待发送邮件"
    Exit Sub
End If


PrePath = ThisWorkbook.Path & "\邮件模板"

On Error Resume Next
'检测是否打开Outlook
Set oOutlookApp = GetObject(, "Outlook.Application")

'没打开则打开
If Err <> 0 Then
    Set oOutlookApp = CreateObject("Outlook.Application")
    bStarted = True
End If

'打开word
Set wWordApp = CreateObject("Word.Application")

'显示发送情况
UserForm1.Show 0
With UserForm1.ProgressBar1
    .Min = 1
    .Max = RowNum + 1
    .Scrolling = 0
End With

For i = 13 To RowNum + 12
    t.Cells(i, 1) = "发送中"
    IsRight = True
    Set oAccount = oOutlookApp.Session.Accounts.Item(t.Cells(6, "H").Value) '设定发送邮箱
    '获取正文
    MyPath = t.Cells(i, 5)

    If Left(MyPath, 1) = "." Then
        MyPath = PrePath & Right(MyPath, Len(MyPath) - 1)
        Debug.Print MyPath
    End If
    MyPath = VBA.Replace(MyPath, ",", "")
    Debug.Print MyPath

    Set SrcDoc = wWordApp.Documents.Open(MyPath)

    '持续替换变量
    Do

        Set Myrange01 = SrcDoc.Range
        Set Myrange02 = SrcDoc.Range
        Set Myrange03 = SrcDoc.Range

        '查找第一个开始符
        Myrange01.Find.ClearFormatting
        With Myrange01.Find
        '查找第一个字符并替换掉
            .Text = StartText
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Myrange01.Find.Execute
        isFind = Myrange01.Find.Found

        '若找到替换符
        If isFind = True Then
            '查找第一个结束符
            Myrange02.Find.ClearFormatting
            With Myrange02.Find
                .Text = EndText
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindStop
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            Myrange02.Find.Execute

            m = Myrange01.Start
            n = Myrange02.Start
            m1 = Myrange01.End
            n1 = Myrange02.End

            '找到变量名称
            Set FoundRange = SrcDoc.Range(m, n1)
            OldStr = FoundRange.Text
            VarName = Mid(OldStr, Len(StartText) + 1, Len(OldStr) - 6)
            Debug.Print VarName

            '找到数据源列
            For k = 1 To ColNum
                If t.Cells(12, k) = VarName Then
                    VarCol = k
                    Exit For
                End If
            Next k


            If VarCol = 0 Then
                t.Cells(i, 1) = "失败：变量名称有误。"
                IsRight = False
                GoTo Prev
            End If

            RepStr = t.Cells(i, VarCol)

            '替换所有此变量
            Myrange03.Find.ClearFormatting
            With Myrange03.Find
                .Text = OldStr
                .Replacement.Text = RepStr
                .Forward = True
                .Wrap = wdFindStop
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            Myrange03.Find.Execute Replace:=wdReplaceAll
        End If

    Loop While isFind = True

'   TmpBody = SrcDoc.Range.Text
    SavePath = PrePath & "\" & TmpFileName
    Debug.Print SavePath

    SrcDoc.SaveAs Filename:=SavePath, FileFormat:=wdFormatHTML, _
        LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
        :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False
    SrcDoc.Close savechanges:=False

    TmpBody = GetHtmlText(PrePath & "\" & TmpFileName)
    MyFile.DeleteFile (PrePath & "\" & TmpFileName)

   '生成收件人和抄送人
    Dim a As String, b As String
    a = t.Cells(i, 2).Value
    b = t.Cells(i, 3).Value
    '新建邮件
    If IsRight = True Then
        '对于收件人、抄送人，增加后缀@pingan.com.cn 确保如邮箱错误等情况可以看出来
        If t.Cells(5, "H").Value <> "是" Then
            a = Replace(a, ";", """@pingan.com.cn;""")
            b = Replace(b, ";", """@pingan.com.cn;""")
            a = a & """@pingan.com.cn"""
            If b <> "" Then b = b & """@pingan.com.cn"""
        End If

        Set oItem = oOutlookApp.CreateItem(olMailItem)
        With oItem
            .SendUsingAccount = oAccount '设定发送邮箱
            .Subject = t.Cells(i, 4)
            .HTMLBody = TmpBody
            '去除"号
            .To = VBA.Replace(a, """", "")
            .CC = VBA.Replace(b, """", "")
            Debug.Print VBA.Replace(a, """", "")
            Debug.Print VBA.Replace(b, """", "")
            If t.Cells(i, 6) <> "" Then
            .Attachments.Add ThisWorkbook.Path & "\附件\" & t.Cells(i, 6).Value
            End If
            .Send
        End With
        Set oItem = Nothing
        t.Cells(i, 1) = "成功"

        '显示发送到第几份
        On Error Resume Next
        UserForm1.ProgressBar1.Value = i - 12
        On Error GoTo 0
        UserForm1.Caption = "共有" & RowNum - 1 & " 封邮件待发送，正进行第" & i - 12 & "发送,请稍候!"
    End If

Prev:

Next i
'卸载窗口
Unload UserForm1

Set MyFile = Nothing
wWordApp.Quit
Set wWordApp = Nothing
If bStarted = True Then
    oOutlookApp.Quit
End If

Set oOutlookApp = Nothing

windows文件管理

• 实现文件和文件夹的修改、移动、删除等

Private Sub CommandButton1_Click() '上传文件
Dim iarray, flname As String, a
Dim ipath As String
Dim folderexist As Boolean, FileExist As Boolean
Dim imsg As Integer, ioption As String

ipath = "\\dqsh-d8403\share\招聘"

If ListBox1.Value <> "" And TextBox1.Value <> "" Then
iarray = VBA.Split(TextBox1.Value, "\")
flname = iarray(UBound(iarray, 1))
    If OptionButton1.Value = True Then
        ioption = OptionButton1.Caption
    ElseIf OptionButton2.Value = True Then
        ioption = OptionButton2.Caption
    ElseIf OptionButton5.Value = True Then
        ioption = OptionButton5.Caption
    ElseIf OptionButton6.Value = True Then
        ioption = OptionButton6.Caption
    ElseIf OptionButton7.Value = True Then
        ioption = OptionButton7.Caption
    ElseIf OptionButton8.Value = True Then
        ioption = OptionButton8.Caption
    Else
        MsgBox "请选择上传类型"
        Exit Sub
    End If

    Debug.Print ipath & "\" & iChannel & "\" & ListBox1.Value & "\" & ioption & "\*"
    FileExist = (Dir(ipath & "\" & iChannel & "\" & ListBox1.Value & "\" & ioption & "\*", vbNormal + vbReadOnly + vbHidden) <> "")

    If FileExist = False Then
        mkfile ipath & "\" & iChannel & "\" & ListBox1.Value & "\" & ioption
        FileCopy TextBox1.Value, ipath & "\" & iChannel & "\" & ListBox1.Value & "\" & ioption & "\" & flname
    Else
        imsg = MsgBox("已存在" & ioption & ",是否替换？", 4 + 32)
        If imsg = 6 Then '替换
            Kill ipath & "\" & iChannel & "\" & ListBox1.Value & "\" & ioption & "\*"
            FileCopy TextBox1.Value, ipath & "\" & iChannel & "\" & ListBox1.Value & "\" & ioption & "\" & flname
        Else
            FileCopy TextBox1.Value, ipath & "\" & iChannel & "\" & ListBox1.Value & "\" & ioption & "\" & flname
        End If
    End If
Else
    MsgBox "请选择员工和上传文件"
    Exit Sub
End If
MsgBox "已上传"

End Sub

Private Sub CommandButton2_Click() '下载文件
Dim flpath As String, ipath As String
Dim ioption As String
Dim FileExist As Boolean
Dim i As Integer
Dim iarray, flname As String
Dim myfile As String

ipath = "\\dqsh-d8403\share\招聘"
If ListBox2.Value = "" Then
    MsgBox "请选择员工"
    Exit Sub
End If
If OptionButton3.Value = True Then
    ioption = OptionButton3.Caption
ElseIf OptionButton4.Value = True Then
    ioption = OptionButton4.Caption
ElseIf OptionButton9.Value = True Then
    ioption = OptionButton9.Caption
ElseIf OptionButton10.Value = True Then
    ioption = OptionButton10.Caption
ElseIf OptionButton11.Value = True Then
    ioption = OptionButton11.Caption
ElseIf OptionButton12.Value = True Then
    ioption = OptionButton12.Caption
Else
    MsgBox "请选择下载类型"
    Exit Sub
End If

myfile = Dir(ipath & "\" & iChannel & "\" & ListBox2.Value & "\" & ioption & "\*")
Debug.Print ipath & "\" & iChannel & "\" & ListBox2.Value & "\" & ioption & "\*"
If myfile <> "" Then
    flpath = Application.GetSaveAsFilename(Title:="选择下载到", InitialFileName:="根据实际文件名决定-无需填写")
    iarray = VBA.Split(flpath, "\")
    flname = iarray(0)
    For i = 1 To UBound(iarray) - 1
        flname = flname & "\" & iarray(i)
    Next
        FileCopy ipath & "\" & iChannel & "\" & ListBox2.Value & "\" & ioption & "\" & myfile, flname & "\" & myfile
    myfile = Dir
    Do While myfile <> ""
        FileCopy ipath & "\" & iChannel & "\" & ListBox2.Value & "\" & ioption & "\" & myfile, flname & "\" & myfile
        myfile = Dir
    Loop
Else
    MsgBox "缺少相关附件"
    Exit Sub
End If

MsgBox "已下载"

End Sub

Private Function mkfile(flpath As String)
Dim iarray, folderexist As Boolean
Dim i As Integer, tmppath As String

iarray = VBA.Split(flpath, "\")
tmppath = iarray(0)
For i = 1 To UBound(iarray, 1)
    tmppath = tmppath & "\" & iarray(i)
    If i > 3 Then
        folderexist = (Dir(tmppath, vbDirectory + vbHidden) <> "")
        If folderexist = False Then
            MkDir tmppath
        End If
    End If
Next
End Function

与数据库建立连接

实现查、删、改、增等基础sql操作，以及事件调用、数据表创建等复杂操作。

• 把excel表作为数据源进行sql操作

Sub Test()
Dim Conn As Object, Rst As Object
Dim strConn As String, strSQL As String
Dim i As Integer, PathStr As String
Set Conn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")
PathStr = ThisWorkbook.FullName   '设置工作簿的完整路径和名称
Select Case Application.Version * 1  '设置连接字符串,根据版本创建连接
    Case Is <= 11
        strConn = "Provider=Microsoft.Jet.Oledb.4.0;ExtendedProperties=excel8.0;Datasource=" & PathStr
    Case Is >= 12
        strConn = "Provider=Microsoft.ACE.OLEDB.12.0;DataSource=" & PathStr & ";ExtendedProperties=""Excel12.0;HDR=YES"";"""
End Select  '设置SQL查询语句
strSQL = "请写入SQL语句"
Conn.Open strConn  '打开数据库链接
Set Rst = Conn.Execute(strSQL) '执行查询，并将结果输出到记录集对象
With Sheet3.Cells.Clear
    For i = 0 To Rst.Fields.Count - 1 '填写标题
        .Cells(1, i + 1) = Rst.Fields(i).Name
    Next i
    .Range("A2").CopyFromRecordset Rst
    .Cells.EntireColumn.AutoFit '自动调整列宽
End With
Rst.Close '关闭数据库连接
Conn.Close
Set Con = Nothing
End Sub

• 对sql service数据库进行操作

'此类用于所有与sql数据库的主连接及相关的数据操作

Dim MainCnn As ADODB.Connection
Dim MainPath As String
Dim MyRs As ADODB.Recordset


Property Get MyCon() As ADODB.Connection
Set MyCon = MainCnn
End Property

Public Function GetConState() As Boolean

If MainCnn Is Nothing Then
    GetConState = False
ElseIf MainCnn.State = adStateClosed Then
    GetConState = False
Else
    GetConState = True
End If


End Function

Public Sub Ini(Path As String)
MainPath = Trim(Path)
End Sub

Public Function ConOpen()

Set MainCnn = New ADODB.Connection
Set MyRs = New ADODB.Recordset
ConOpen = True
On Error GoTo errDo:
With MainCnn
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & MainPath & "; Jet OLEDB:Database Password=" & MaxPwdCell
'    .ConnectionString = "DBQ=" & ThisWorkbook.Path & "\归集表数据库.mdb;" & _
'                        "Driver={Microsoft Access Driver (*.mdb)};" & _
'                        "uid=admin;Password=seudit;"
'此处代码用于和access数据库连接

    'Debug.Print .ConnectionString
    .Open
End With
On Error GoTo 0

ConOpen = "Fine"

Exit Function

errDo:
'    Debug.Print MainPath
    ConOpen = "数据源尚未连接或有误，请配置正确的数据源地址。"

End Function


Public Function ConOpenByStr()

Set MainCnn = New ADODB.Connection
Set MyRs = New ADODB.Recordset
ConOpenByStr = True
On Error GoTo errDo:

With MainCnn
    .ConnectionString = MainPath
    .CommandTimeout = 180
    .ConnectionTimeout = 180
    .Open
    .CursorLocation = adUseClient
End With
On Error GoTo 0

ConOpenByStr = "Fine"

Exit Function

errDo:
    ConOpenByStr = "数据源尚未连接或有误，请配置正确的数据源地址。"

End Function

'传入Sql的select
Public Function GetRs(sql As String, Optional IsReadOnly As Boolean = True) As ADODB.Recordset

If IsReadOnly = True Then
    MyRs.Open sql, MainCnn, adOpenKeyset, adLockReadOnly
Else
    MyRs.Open sql, MainCnn, adOpenKeyset, adLockOptimistic
End If

Set GetRs = MyRs

End Function

Public Function CloseRs() As String
MyRs.Close
End Function

Public Function ConClose() As String
MainCnn.Close
End Function

'传入Sql的Delete
Public Function DelRs(sql As String) As String

MainCnn.Execute (sql)

End Function

'传入Sql的Insert
Public Function InsertRsBySql(sql As String) As String

MainCnn.Execute (sql)

End Function


'传入数据区域的的Insert,必须保证数据库表结构与导入区域结构一致
Public Function InsertRsByRange(UseRange As Range, InsertTName As String, NeedID As Boolean) As String
Dim sql As String
Dim RNum As Integer, CNum As Integer

RNum = UseRange.Rows.Count
CNum = UseRange.Columns.Count

For i = 1 To RNum
    If NeedID = True Then
        sql = "insert into " & InsertTName & " values(" & i & ",'"
    Else
        sql = "insert into " & InsertTName & " values('"
    End If
    For j = 1 To CNum
        sql = sql & Trim(UseRange.Cells(i, j)) & "','"
    Next j
    sql = Left(sql, Len(sql) - 2) & ")"
    Debug.Print sql
    MainCnn.Execute (sql)
Next i

End Function

操作网页

• 实现网页操作自动化，网页信息自动抓取等
  除了下面这种所得即所见的网页操作方式，还有一种模拟发包收包的操作方式。

Sub 主程序()
Dim ie As InternetExplorer, id As String, i As Integer, r As Integer
Set ie = CreateObject("internetExplorer.application")   '创建一个空的ie
ie.Visible = True                               '让ie可见
ie.Navigate "http://xxxxxxxxx"
Do While ie.ReadyState <> 4 Or ie.Busy  '等待ie完毕加载
    DoEvents
Loop

r = Me.Cells(1, 1).CurrentRegion.Rows.Count
For i = 2 To r '滚动维护数据
    If Me.Cells(i, 2).Value = "是" Then
    Else
    id = Me.Cells(i, 1).Value
    zdtx2015 ie, id '维护主模块
    Me.Cells(i, 2).Value = "是"
    End If
Next

End Sub

Function zdtx2015(ie As InternetExplorer, id As String)
Dim ie2, i As Integer, ie3, ie4, ie5, ie7, ie6, ie8, ie9


Set ie2 = ie.Document.frames(0).Document.getElementById("EMPLMT_SRCH_COR_EMPLID")
Do Until Not ie2 Is Nothing
DoEvents
Set ie2 = ie.Document.frames(0).Document.getElementById("EMPLMT_SRCH_COR_EMPLID")
Loop
ie2.Value = id '输入员工ID"

Set ie4 = ie.Document.frames(0).Document.getElementsByTagName("INPUT")(33)
ie4.Click '点击搜索

Set ie5 = ie.Document.frames(0).Document.getElementsByTagName("INPUT")(26)
Do Until ie5.Value = "职位数据覆盖"
DoEvents
Set ie5 = ie.Document.frames(0).Document.getElementsByTagName("INPUT")(26)
Loop
ie5.Click '职务数据覆盖点一下\

Set ie8 = ie.Document.frames(0).Document.getElementById("#ICList")
ie8.Click '返回
'SendKeys "%1"
End Function

制作窗体实现交互

自动化实现复杂的数据处理操作

• 对表格内数据进行决策树分析

Dim tree, itree, iColCount As Integer
'Set tree = CreateObject("scripting.dictionary") '创建树
'已1开始的数组中，节点i的n个子节点的下标为ni和ni+1；而其父节点的下标为int(i,n)

Sub 决策树()
Dim arr, arr0, dichx, tree, dic, loc As Long, brr, crr
arr = Me.Cells(1, 1).CurrentRegion '数据源
arr0 = Me.Cells(2, 1).Resize(UBound(arr, 1) - 1, UBound(arr, 2)) '训练元组
Set dichx = CreateObject("scripting.dictionary") '候选属性的集合
For i = 2 To UBound(arr, 2) - 1
    dichx(arr(1, i)) = i
Next
Set dic = CreateObject("scripting.dictionary") '有多少结果值
For i = 1 To UBound(arr0, 1)
    If dic.exists(arr0(i, UBound(arr0, 2))) Then
        dic(arr0(i, UBound(arr0, 2))) = dic(arr0(i, UBound(arr0, 2))) + 1
    Else
        dic(arr0(i, UBound(arr0, 2))) = 1
    End If
Next

Set tree = CreateObject("scripting.dictionary") '创建类树
Set itree = CreateObject("scripting.dictionary") '创建分叉树

loc = 1: iColCount = UBound(arr, 2) - 2 '属性量
generate_decision_tree arr0, dichx, loc, dic, tree, itree

crr = tree.keys
Me.Cells(1, 9).Resize(1, UBound(crr) + 1) = crr
crr = tree.items
Me.Cells(2, 9).Resize(1, UBound(crr) + 1) = crr
crr = itree.keys
Me.Cells(3, 9).Resize(1, UBound(crr) + 1) = crr
crr = itree.items
For i = 0 To UBound(crr)
    For j = 0 To UBound(crr(i))
        Me.Cells(4, 9).Offset(j, i) = crr(i)(j)
    Next
Next

If Not tree.exists(1) Then Exit Sub
tree_print tree, itree, 1, Me.Cells(9, 9), iColCount


End Sub
Function tree_print(tree, itree, x As Long, ByRef rg As Range, iColCount As Integer)
If tree.exists(x) Then
    If itree.exists(x) Then
    rg.Value = tree(x) & "#" & x
        If IsArray(itree(x)) Then
            arr = itree(x)
            rg.Offset(1, 0).Resize(1, UBound(arr, 1) + 1) = arr
            For i = 0 To UBound(arr, 1)
                rg.Offset(2, i) = tree(x * iColCount + i) & "#" & x * iColCount + i
            Next
            Set rg = rg.Offset(4, 0)

            For i = 0 To UBound(arr, 1)
                tree_print tree, itree, x * iColCount + i, rg, iColCount
            Next
        End If
    End If
End If


End Function


Function generate_decision_tree(arr0, dichx, loc, dic0, tree, itree) '建立决策树
Dim brr0(), split_list(), brr(1 To 20, 1 To 100, 1 To 10)
'Set generate_decision_tree = CreateObject("scripting.dictionary")

If dichx.Count = 0 Then Exit Function
ikey = attri_selection_method(arr0, dichx, dic0) '找到一个最好的划分元祖为个体的属性
iitem = dichx(ikey)
dichx.Remove ikey

tree(loc) = ikey

Set dic = CreateObject("scripting.dictionary") '创建一个包含所有该属性分类的字典
For i = 1 To UBound(arr0, 1)
If arr0(i, 1) = "" Then Exit For
    If dic.exists(arr0(i, iitem)) Then '维护组信息
        dic(arr0(i, iitem)) = dic(arr0(i, iitem)) + 1
        For j = 1 To dic.Count
            If arr0(i, iitem) = split_list(j - 1) Then
                For x = 1 To UBound(arr0, 2)
                    brr(j, dic(arr0(i, iitem)), x) = arr0(i, x)
                Next
            End If
        Next
    Else
        'ReDim Preserve split_list(1 To dic.Count + 1) '创建组类记录表
        'split_list(dic.Count + 1) = arr0(i, iitem) '保存组名称
        dic(arr0(i, iitem)) = 1 '记录组数量
        split_list = dic.keys
        'ReDim Preserve brr(1 To dic.Count, 1 To UBound(arr0, 1), 1 To UBound(arr0, 2)) '维护组信息
        For j = 1 To dic.Count
            If arr0(i, iitem) = split_list(j - 1) Then
                For x = 1 To UBound(arr0, 2)
                    brr(j, dic(arr0(i, iitem)), x) = arr0(i, x)
                Next
            End If
        Next
    End If
Next

iDicCount = dic.Count
For i = 1 To iDicCount
    ReDim brr0(1 To UBound(arr0, 1), 1 To UBound(arr0, 2)) '创建分组表
    Set dic = CreateObject("scripting.dictionary")
    For x = 1 To UBound(brr0, 1)
        If brr(i, x, 1) = "" Then
            Exit For
        Else
            For y = 1 To UBound(brr0, 2)
                brr0(x, y) = brr(i, x, y)
                If dic.exists(brr(i, x, UBound(brr0, 2))) Then
                    dic(brr(i, x, UBound(brr0, 2))) = dic(brr(i, x, UBound(brr0, 2))) + 1
                Else
                    dic(brr(i, x, UBound(brr0, 2))) = 1
                End If
            Next
        End If
    Next
    If dic.Count = 1 Then '如果这个分组都是一个ans
        itree(loc) = split_list
        tree(iColCount * loc + i - 1) = brr0(1, UBound(brr0, 2))
        'Set itree = tree
        'itree(split_list(i)) = dic.keys(0)
    Else
        'ReDim Preserve brr0(1 To x - 1, 1 To UBound(brr0, 2))
        'Set itree(split_list(i)) = CreateObject("scripting.dictionary")
        'Set iitree = itree(split_list(i))
        itree(loc) = split_list
        generate_decision_tree brr0, dichx, iColCount * loc + i - 1, dic, tree, itree
    End If
    Set dic = Nothing
Next

End Function



Function attri_selection_method(arr0, dichx, dic_ans) '最优信息度提升模型


Dim icomput
ReDim icomput(1 To dichx.Count)

endcol = UBound(arr0, 2)
arr_key = dichx.keys

ordcomput = 0 '获取初始信息度
For Each Item In dic_ans.items
    ordcomput = ordcomput - Item / UBound(arr0, 1) * Log(Item / UBound(arr0, 1)) / Log(2)
Next


k = 0
For Each Item In dichx.keys '对每个条件列
Set dic_comput = CreateObject("scripting.dictionary")
irow = dichx(Item)
    For j = 1 To UBound(arr0, 1) '获取每个子条件的结果分布
        If dic_comput.exists(arr0(j, irow)) Then
            If dic_comput(arr0(j, irow)).exists(arr0(j, endcol)) Then
                dic_comput(arr0(j, irow))(arr0(j, endcol)) = dic_comput(arr0(j, irow))(arr0(j, endcol)) + 1
            Else
                dic_comput(arr0(j, irow))(arr0(j, endcol)) = 1
            End If
        Else
            Set dic_comput(arr0(j, irow)) = CreateObject("scripting.dictionary")

        End If
    Next
    allans = 0
    For Each ikey In dic_comput.keys  '对每个子条件
        ans = 0
        totalans = 0
        For Each supikey In dic_comput(ikey).keys
            totalans = totalans + dic_comput(ikey)(supikey)
        Next
        For Each supikey In dic_comput(ikey).keys '求和子条件信息度
        Debug.Print totalans
        Debug.Print dic_comput(ikey)(supikey)
            ans = ans - dic_comput(ikey)(supikey) / totalans * Log(dic_comput(ikey)(supikey) / totalans) / Log(2)
        Next
        allans = allans + totalans / UBound(arr0, 1) * ans
    Next
    k = k + 1
    icomput(k) = allans '获取最终的信息度
Next

Min = 2
For i = 1 To UBound(icomput, 1)
    If icomput(i) < Min Then
        Min = icomput(i)
        attri_selection_method = arr_key(i - 1)
    End If
Next
End Function

其他

• 调用excel自带的pivotable、数据透视表进行数据处理和操作
• 调用微软的API接口进行系统控制和获取系统信息。
• 结合系统定时任务功能，实现自动化定时报表
• 开发小型作业系统平台
• 开发档案管理、进销存、CRM，HRM等管理平台

学习VBA

谁需要学习VBA

• 客观的来说，VBA是一个很老有点过时的语言了，即比不上C语言的系统效能，也比不上python这样面对对象高效编写，更不上JAVA这样有成熟蓬勃的社区支持。
• VBA唯一的优点，在于对于微软系统、尤其是office软件的支持性和亲密性，简单的说他实现了office软件的定制化、自动化和无限强化。
• 那么，适合使用VBA的人群就出来了：长期埋头与大量的EXCEL报表、图表、PPT报告、邮件处理的办公人群，如企划、财务、人事、库管、运营分析等
• 适合使用VBA的企业和部门，报表处理和表格化作业密集的企业和部门，不具备覆盖全面的系统支持；中小型企业；部分咨询公司。
• 对于以上的这些人，学习VBA可以极大的减轻工作压力、提升工作效率，给专业技能的发挥提供更多空间。

如何学习

• 学习VBA，学习office本身的应用功能是基础。实际上，很多情况下最高效的VBA处理方式是在原有的office应用的功能上进行拓展，而不是重新开发一套功能。
  所以，如果你熟悉Excel公式、透视表、数组公式、图表、了解Excel\PPT\outlook等自带的系统功能如邮件合并等，那么在编写VBA过程中是事半功倍的。
• 看书、上论坛、看视频，网上的资源很多，在我另一个帖子中有所介绍
  https://blog.csdn.net/qq_36080693/article/details/53349901

重要的知识点

• 编辑Excel有效性、格式、图表等等
• Ribbon界面设计和功能改造
• 数据库ADO+SQL交互（还要学点SQL语法）
• 窗体控件设计和制作
• 字典dictionary和集合collection
• 数组化处理思想
• 正则表达式
• 类
• webbrowser相关操作
• 文件操作