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界面的动态变化规则，实现动态调整界面。
<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 SubPrivate 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 SubPrivate 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 SubFunction 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相关操作
- 文件操作