天天看點
傳回

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
    VBA，我的第一門語言（帶你走進VBA的世界）
    我們可以在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(, ).CurrentRegion.Rows.Count - 
ColNum = t.Cells(, ).CurrentRegion.Columns.Count

If RowNum =  Then
    MsgBox "無待發送郵件"
    Exit Sub
End If


PrePath = ThisWorkbook.Path & "\郵件模闆"

On Error Resume Next
'檢測是否打開Outlook
Set oOutlookApp = GetObject(, "Outlook.Application")

'沒打開則打開
If Err <>  Then
    Set oOutlookApp = CreateObject("Outlook.Application")
    bStarted = True
End If

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

'顯示發送情況
UserForm1.Show 
With UserForm1.ProgressBar1
    .Min = 
    .Max = RowNum + 
    .Scrolling = 
End With

For i =  To RowNum + 
    t.Cells(i, ) = "發送中"
    IsRight = True
    Set oAccount = oOutlookApp.Session.Accounts.Item(t.Cells(, "H").Value) '設定發送郵箱
    '擷取正文
    MyPath = t.Cells(i, )

    If Left(MyPath, ) = "." Then
        MyPath = PrePath & Right(MyPath, Len(MyPath) - )
        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) + , Len(OldStr) - )
            Debug.Print VarName

            '找到資料源列
            For k =  To ColNum
                If t.Cells(, k) = VarName Then
                    VarCol = k
                    Exit For
                End If
            Next k


            If VarCol =  Then
                t.Cells(i, ) = "失敗：變量名稱有誤。"
                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, ).Value
    b = t.Cells(i, ).Value
    '建立郵件
    If IsRight = True Then
        '對于收件人、抄送人，增加字尾@pingan.com.cn 確定如郵箱錯誤等情況可以看出來
        If t.Cells(, "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, )
            .HTMLBody = TmpBody
            '去除"号
            .To = VBA.Replace(a, """", "")
            .CC = VBA.Replace(b, """", "")
            Debug.Print VBA.Replace(a, """", "")
            Debug.Print VBA.Replace(b, """", "")
            If t.Cells(i, ) <> "" Then
            .Attachments.Add ThisWorkbook.Path & "\附件\" & t.Cells(i, ).Value
            End If
            .Send
        End With
        Set oItem = Nothing
        t.Cells(i, ) = "成功"

        '顯示發送到第幾份
        On Error Resume Next
        UserForm1.ProgressBar1.Value = i - 
        On Error GoTo 
        UserForm1.Caption = "共有" & RowNum -  & " 封郵件待發送，正進行第" & i -  & "發送,請稍候!"
    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, ))
    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 & ",是否替換？",  + )
        If imsg =  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()
    For i =  To UBound(iarray) - 
        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()
For i =  To UBound(iarray, )
    tmppath = tmppath & "\" & iarray(i)
    If i >  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 *   '設定連接配接字元串,根據版本建立連接配接
    Case Is <= 
        strConn = "Provider=Microsoft.Jet.Oledb.4.0;ExtendedProperties=excel8.0;Datasource=" & PathStr
    Case Is >= 
        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 =  To Rst.Fields.Count -  '填寫标題
        .Cells(, i + ) = 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 

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 = 
    .ConnectionTimeout = 
    .Open
    .CursorLocation = adUseClient
End With
On Error GoTo 

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 =  To RNum
    If NeedID = True Then
        sql = "insert into " & InsertTName & " values(" & i & ",'"
    Else
        sql = "insert into " & InsertTName & " values('"
    End If
    For j =  To CNum
        sql = sql & Trim(UseRange.Cells(i, j)) & "','"
    Next j
    sql = Left(sql, Len(sql) - ) & ")"
    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 <>  Or ie.Busy  '等待ie完畢加載
    DoEvents
Loop

r = Me.Cells(, ).CurrentRegion.Rows.Count
For i =  To r '滾動維護資料
    If Me.Cells(i, ).Value = "是" Then
    Else
    id = Me.Cells(i, ).Value
    zdtx2015 ie, id '維護主子產品
    Me.Cells(i, ).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().Document.getElementById("EMPLMT_SRCH_COR_EMPLID")
Do Until Not ie2 Is Nothing
DoEvents
Set ie2 = ie.Document.frames().Document.getElementById("EMPLMT_SRCH_COR_EMPLID")
Loop
ie2.Value = id '輸入員工ID"

Set ie4 = ie.Document.frames().Document.getElementsByTagName("INPUT")()
ie4.Click '點選搜尋

Set ie5 = ie.Document.frames().Document.getElementsByTagName("INPUT")()
Do Until ie5.Value = "職位資料覆寫"
DoEvents
Set ie5 = ie.Document.frames().Document.getElementsByTagName("INPUT")()
Loop
ie5.Click '職務資料覆寫點一下\

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

制作窗體實作互動

VBA，我的第一門語言（帶你走進VBA的世界）
VBA，我的第一門語言（帶你走進VBA的世界）

自動化實作複雜的資料處理操作

  • 對表格内資料進行決策樹分析 
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(, ).CurrentRegion '資料源
arr0 = Me.Cells(, ).Resize(UBound(arr, ) - , UBound(arr, )) '訓練元組
Set dichx = CreateObject("scripting.dictionary") '候選屬性的集合
For i =  To UBound(arr, ) - 
    dichx(arr(, i)) = i
Next
Set dic = CreateObject("scripting.dictionary") '有多少結果值
For i =  To UBound(arr0, )
    If dic.exists(arr0(i, UBound(arr0, ))) Then
        dic(arr0(i, UBound(arr0, ))) = dic(arr0(i, UBound(arr0, ))) + 
    Else
        dic(arr0(i, UBound(arr0, ))) = 
    End If
Next

Set tree = CreateObject("scripting.dictionary") '建立類樹
Set itree = CreateObject("scripting.dictionary") '建立分叉樹

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

crr = tree.keys
Me.Cells(, ).Resize(, UBound(crr) + ) = crr
crr = tree.items
Me.Cells(, ).Resize(, UBound(crr) + ) = crr
crr = itree.keys
Me.Cells(, ).Resize(, UBound(crr) + ) = crr
crr = itree.items
For i =  To UBound(crr)
    For j =  To UBound(crr(i))
        Me.Cells(, ).Offset(j, i) = crr(i)(j)
    Next
Next

If Not tree.exists() Then Exit Sub
tree_print tree, itree, , Me.Cells(, ), 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(, ).Resize(, UBound(arr, ) + ) = arr
            For i =  To UBound(arr, )
                rg.Offset(, i) = tree(x * iColCount + i) & "#" & x * iColCount + i
            Next
            Set rg = rg.Offset(, )

            For i =  To UBound(arr, )
                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( To ,  To ,  To )
'Set generate_decision_tree = CreateObject("scripting.dictionary")

If dichx.Count =  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 =  To UBound(arr0, )
If arr0(i, ) = "" Then Exit For
    If dic.exists(arr0(i, iitem)) Then '維護組資訊
        dic(arr0(i, iitem)) = dic(arr0(i, iitem)) + 
        For j =  To dic.Count
            If arr0(i, iitem) = split_list(j - ) Then
                For x =  To UBound(arr0, )
                    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)) =  '記錄組數量
        split_list = dic.keys
        'ReDim Preserve brr(1 To dic.Count, 1 To UBound(arr0, 1), 1 To UBound(arr0, 2)) '維護組資訊
        For j =  To dic.Count
            If arr0(i, iitem) = split_list(j - ) Then
                For x =  To UBound(arr0, )
                    brr(j, dic(arr0(i, iitem)), x) = arr0(i, x)
                Next
            End If
        Next
    End If
Next

iDicCount = dic.Count
For i =  To iDicCount
    ReDim brr0( To UBound(arr0, ),  To UBound(arr0, )) '建立分組表
    Set dic = CreateObject("scripting.dictionary")
    For x =  To UBound(brr0, )
        If brr(i, x, ) = "" Then
            Exit For
        Else
            For y =  To UBound(brr0, )
                brr0(x, y) = brr(i, x, y)
                If dic.exists(brr(i, x, UBound(brr0, ))) Then
                    dic(brr(i, x, UBound(brr0, ))) = dic(brr(i, x, UBound(brr0, ))) + 
                Else
                    dic(brr(i, x, UBound(brr0, ))) = 
                End If
            Next
        End If
    Next
    If dic.Count =  Then '如果這個分組都是一個ans
        itree(loc) = split_list
        tree(iColCount * loc + i - ) = brr0(, UBound(brr0, ))
        '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 - , dic, tree, itree
    End If
    Set dic = Nothing
Next

End Function



Function attri_selection_method(arr0, dichx, dic_ans) '最優資訊度提升模型


Dim icomput
ReDim icomput( To dichx.Count)

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

ordcomput =  '擷取初始資訊度
For Each Item In dic_ans.items
    ordcomput = ordcomput - Item / UBound(arr0, ) * Log(Item / UBound(arr0, )) / Log()
Next


k = 
For Each Item In dichx.keys '對每個條件列
Set dic_comput = CreateObject("scripting.dictionary")
irow = dichx(Item)
    For j =  To UBound(arr0, ) '擷取每個子條件的結果分布
        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)) + 
            Else
                dic_comput(arr0(j, irow))(arr0(j, endcol)) = 
            End If
        Else
            Set dic_comput(arr0(j, irow)) = CreateObject("scripting.dictionary")

        End If
    Next
    allans = 
    For Each ikey In dic_comput.keys  '對每個子條件
        ans = 
        totalans = 
        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()
        Next
        allans = allans + totalans / UBound(arr0, ) * ans
    Next
    k = k + 
    icomput(k) = allans '擷取最終的資訊度
Next

Min = 
For i =  To UBound(icomput, )
    If icomput(i) < Min Then
        Min = icomput(i)
        attri_selection_method = arr_key(i - )
    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相關操作
  • 檔案操作
資料 vba 程式設計語言
上一篇: java的酒店房間管理系統摘要第 一 章 緒論第 二 章 相關技術簡介第 三 章 需求分析第 四 章 系統總體功能第 五 章 資料庫設計第 六 章 各功能子產品第 七 章 調試與結果第 八 章 總結參考文獻緻 謝
下一篇: 絕地求生大逃殺DLL140dll出錯怎麼辦？

繼續閱讀