VBA基础知识整理（字典，自定义函数）

字典
基本概念

'1 什么是VBA字典？
   '字典（dictionary）是一个储存数据的小仓库。共有两列。
      '第一列叫key , 不允许有重复的元素。
      '第二列是item,每一个key对应一个item，本列允许为重复
            'Key   item
             'A     10
             'B     20
             'C     30
             'Z     10

'2 即然有数组，为什么还要学字典？
   '原因:提速，具体表现在
      '1) A列只能装入非重复的元素，利用这个特点可以很方便的提取不重复的值
      '2) 每一个key对应一个唯一的item，只要指点key的值，就可以马上返回其对应的item，利用字典可以实现快速的查找

'3 字典有什么局限？
    '字典只有两列，如果要处理多列的数据，还需要通过字符串的组合和拆分来实现。
    '字典调用会耗费一定时间，如果是数据量不大，字典的优势就无法体现出来。
    
'4 字典在哪里？如何创建字典？
    
    '字典是由scrrun.dll链接库提供的，要调用字典有两种方法
      '第一种方法：直接创建法
        'Set d = CreateObject("scripting.dictionary")
      '第二种方法：引用法
        '工具-引用-浏览-找到scrrun.dll-确定

字典操作

'1 装入数据
  Sub t1()
      Dim d As New Dictionary
      Dim x As Integer
      
      For x = 2 To 4
       		d.Add Cells(x, 1).Value, Cells(x, 2).Value
      Next x
      
      MsgBox d.Keys(1)
      'Stop
  End Sub
  ------------------------

'2 读取数据

 Sub t2()
      Dim d
      Dim arr
      Dim x As Integer
      Set d = CreateObject("scripting.dictionary")
      
      For x = 2 To 4
       	  d.Add Cells(x, 1).Value, Cells(x, 2).Value
      Next x
      
      'MsgBox d("李四")
      'MsgBox d.Keys(2)
      Range("d1").Resize(d.Count) = Application.Transpose(d.Keys)  '关键字
      Range("e1").Resize(d.Count) = Application.Transpose(d.Items)	‘元素
      arr = d.Items
 End Sub

3 修改数据

Sub t3()
      Dim d As New Dictionary
      Dim x As Integer
      
      For x = 2 To 4
       d.Add Cells(x, 1).Value, Cells(x, 2).Value
      Next x
      
      d("李四") = 78
      MsgBox d("李四")
      d("赵六") = 100
      MsgBox d("赵六")
End Sub

'4 删除数据

Sub t4()
      Dim d As New Dictionary
      Dim x As Integer
      
      For x = 2 To 4
        d(Cells(x, 1).Value) = Cells(x, 2).Value
      Next x
      
       d.Remove "李四"
     ' MsgBox d.Exists("李四")
      d.RemoveAll
      MsgBox d.Count
End Sub

'区分大小写

 Sub t5()
      Dim d As New Dictionary
      Dim x
      
      For x = 1 To 5
        d(Cells(x, 1).Value) = ""
      Next x
      
      Stop
 End Sub

字典与查找

Sub 多表双向查找()
     Dim d As New Dictionary
     Dim x, y
     Dim arr
     
     For x = 3 To 5
       arr = Sheets(x).Range("a2").Resize(Sheets(x).Range("a65536").End(xlUp).Row - 1, 2)
       
       For y = 1 To UBound(arr)
         d(arr(y, 1)) = arr(y, 2)
         d(arr(y, 2)) = arr(y, 1)
       Next y
       
     Next x
     
     MsgBox d("C1")
     MsgBox d("吴情")
End Sub

字典与求和

Sub 汇总()
     Dim d As New Dictionary
     Dim arr, x
     arr = Range("a2:b10")
     
     For x = 1 To UBound(arr)
       d(arr(x, 1)) = d(arr(x, 1)) + arr(x, 2) 'key对应的item的值在原来的基础上加新的
     Next x
     
     Range("d2").Resize(d.Count) = Application.Transpose(d.Keys)
     Range("e2").Resize(d.Count) = Application.Transpose(d.Items)
End Sub

字典与唯一值

Sub 提取不重复的产品()
     Dim d As New Dictionary
     Dim arr, x
     arr = Range("a2:a12")
     
     For x = 1 To UBound(arr)
          d(arr(x, 1)) = ""
     Next x
     
     Range("c2").Resize(d.Count) = Application.Transpose(d.Keys)
End Sub

多列汇总

Sub 下棋法之多列汇总()
 Dim 棋盘(1 To 10000, 1 To 3)
 Dim 行数
 Dim arr, x, k
 Dim d As New Dictionary
 arr = Range("a2:c" & Range("a65536").End(xlUp).Row)
 
 For x = 1 To UBound(arr)
   If d.Exists(arr(x, 1)) Then
      行数 = d(arr(x, 1))
      棋盘(行数, 2) = 棋盘(行数, 2) + arr(x, 2)
      棋盘(行数, 3) = 棋盘(行数, 3) + arr(x, 3)
   Else
      k = k + 1
      d(arr(x, 1)) = k
      棋盘(k, 1) = arr(x, 1)
      棋盘(k, 2) = arr(x, 2)
      棋盘(k, 3) = arr(x, 3)
   End If
 Next x
 
 Range("f2").Resize(k, 3) = 棋盘
End Sub

多条件多列汇总

Sub 下棋法之多条件多列汇总()
 Dim 棋盘(1 To 10000, 1 To 4)
 Dim 行数
 Dim arr, x As Integer, sr As String, k As Integer
 Dim d As New Dictionary
 arr = Range("a2:d" & Range("a65536").End(xlUp).Row)
 
 For x = 1 To UBound(arr)
    sr = arr(x, 1) & "-" & arr(x, 2)
    If d.Exists(sr) Then
      行数 = d(sr)
      棋盘(行数, 3) = 棋盘(行数, 3) + arr(x, 3)
      棋盘(行数, 4) = 棋盘(行数, 4) + arr(x, 4)
    Else
      k = k + 1
      d(sr) = k
      棋盘(k, 1) = arr(x, 1)
      棋盘(k, 2) = arr(x, 2)
      棋盘(k, 3) = arr(x, 3)
      棋盘(k, 4) = arr(x, 4)
    End If
 Next x
 
   Range("g2").Resize(k, 4) = 棋盘
End Sub

数据透视式汇总

Sub 下棋法之数据透视表式汇总()
     Dim d As New Dictionary
     Dim 棋盘(1 To 10000, 1 To 7)
     Dim 行数, 列数
     Dim arr, x, k
     
     arr = Range("a2:c" & Range("a65536").End(xlUp).Row)
     
     For x = 1 To UBound(arr)
       列数 = (InStr("1月2月3月4月5月6月", arr(x, 2)) + 1) / 2 + 1
       If d.Exists(arr(x, 1)) Then
          行数 = d(arr(x, 1))
          
          棋盘(行数, 列数) = 棋盘(行数, 列数) + arr(x, 3)
       Else
          k = k + 1
          d(arr(x, 1)) = k
          棋盘(k, 1) = arr(x, 1)
          棋盘(k, 列数) = arr(x, 3)
       End If
     Next x
     
     Range("f2").Resize(k, 7) = 棋盘

End Sub

自定义函数

什么是自定义函数

'1 什么是自定义函数？
  '在VBA中有VBA函数，我们还可以调用工作表函数，我们能不能自已编写函数呢？可以，这就是本集所讲的自定义函数
  
'2 怎么编写自定义函数？
 
   '我们可以按下面的结构编写自定义函数
  
    ' Function 函数名称(参数1,参数2....)
         
         '代码
         '函数名称=返回的值或数组
         set 返回集合对象
    ' End Function

编写和使用自定义函数
'1 取得工作表总个数的自定义函数

Function shcount()
	     shcount = Sheets.Count
 End Function
 ----------------------------------
Sub dd()
     MsgBox getv(Range("a7"))
End Sub

'2 取得单元格显示值的自定义函数

  Function getv(rg As Range)
          	getv = rg.Text
  End Function

'3 截取字符串的函数

 Function jiequ(sr As String, fh As String, wz As Integer)
    
    Dim Arr
    Arr = Split(sr, fh)
    jiequ = Arr(wz - 1)
    
 End Function
 -----------------------------------------------------
 Sub test()
    MsgBox jiequ("A-BRT-C-EF", "-", 2)
  End Sub

'4 提取不重复值的个数

  Function 不重复个数(rg As Range)
       Dim d, Arr, ar
       Arr = rg
       Set d = CreateObject("scripting.dictionary")
       
       For Each ar In Arr
         d(ar) = ""
       Next ar
       
       不重复个数 = d.Count
  End Function

参数值默认和参数缺省

Function shuiji2(maxnum, geshu, Optional qo As Integer = 2)
     Dim d As New Dictionary
     Dim num, m
     Application.Volatile
     m = 1
     
     Do
	       num = Int(Rnd() * maxnum + 1)
	       
	       If qo = 2 Then
	        If num Mod 2 = 0 Then d(num) = ""
	       ElseIf qo = 1 Then
	        If Not num Mod 2 = 0 Then d(num) = ""
	       Else
	        Exit Function
	       End If
	       
     Loop Until d.Count = geshu
     
     shuiji2 = Application.Transpose(d.Keys)
End Function