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相關操作
• 文件操作