VBA学习笔记-02

目录

CH6 单元格操作

CH7 EXCEL事件

CH8 VBA数组

CH9 VBA字典

<br />

---

<br />

CH6 单元格操作

一、单元格的选取

1 表示一个单元格(a1)

 Sub s()
       Range("a1").Select
       Cells(1, 1).Select
       Range("A" & 1).Select
       Cells(1, "A").Select
       Cells(1).Select
       [a1].Select
 End Sub

2 表示相邻单元格区域

 Sub d()                              ‘选取单元格a1:c5
         Range("a1:c5").Select
         Range("A1", "C5").Select
         Range(Cells(1, 1), Cells(5, 3)).Select
         Range("a1:a10").Offset(0, 1).Select
        Range("a1").Resize(5, 3).Select
 End Sub

3 表示不相邻的单元格区域

Sub d1()

  Range("a1,c1:f4,a7").Select
  
  Union(Range("a1"), Range("c1:f4"), Range("a7")).Select
  
End Sub

Sub dd() union示例
  Dim rg As Range, x As Integer
  For x = 2 To 10 Step 2
    If x = 2 Then Set rg = Cells(x, 1)
    
    Set rg = Union(rg, Cells(x, 1))
  Next x
  rg.Select
End Sub

4 表示行

Sub h()    
  Rows(1).Select
  Rows("3:7").Select
  Range("1:2,4:5").Select
   Range("c4:f5").EntireRow.Select       
End Sub

5 表示列

 Sub L()    
   Columns(1).Select
   Columns("A:B").Select
   Range("A:B,D:E").Select
  Range("c4:f5").EntireColumn.Select 选取c4:f5所在的行       
 End Sub

6 重置坐标下的单元格表示方法

Sub cc()

  Range("b2").Range("a1") = 100
  
End Sub

7 表示正在选取的单元格区域

 Sub d2()
       Selection.Value = 100
 End Sub

二、特殊单元格定位

1 已使用的单元格区域

Sub d1()  
      Sheets("sheet2").UsedRange.Select    
      wb.Sheets(1).Range("a1:a10").Copy Range("i1")    
End Sub

2 某单元格所在的单元格区域

 Sub d2()    
      Range("b8").CurrentRegion.Select    
 End Sub

3 两个单元格区域共同的区域

Sub d3()     
      Intersect(Columns("b:c"), Rows("3:5")).Select  
End Sub

4 调用定位条件选取特殊单元格

Sub d4()  
   Range("A1:A6").SpecialCells(xlCellTypeBlanks).Select       
End Sub

5 端点单元格

 Sub d5()   
       Range("a65536").End(xlUp).Offset(1, 0) = 1000     
 End Sub

 Sub d6()   
       Range(Range("b6"), Range("b6").End(xlToRight)).Select     
 End Sub

三、单元格信息

1 单元格的值

 Sub x1()
        Range("b10") = Range("c2").Value
        Range("b11") = Range("c2").Text
      Range("c10") = "" & Range("I3").Formula
 End Sub

2 单元格的地址

Sub x2()
 With Range("b2").CurrentRegion
   [b12] = .Address
   [c12] = .Address(0, 0)
   [d12] = .Address(1, 0)
   [e12] = .Address(0, 1)
   [f12] = .Address(1, 1)
 End With
End Sub

3 单元格的行列信息

Sub x3()
  With Range("b2").CurrentRegion
    [b13] = .Row
    [b14] = .Rows.Count
    [b15] = .Column
    [b16] = .Columns.Count
    [b17] = .Range("a1").Address
  End With
End Sub

4、单元格的格式信息

Sub x4()
  With Range("b2")
    [b19] = .Font.Size
    [b20] = .Font.ColorIndex
    [b21] = .Interior.ColorIndex
    [b22] = .Borders.LineStyle
  End With
End Sub

5、单元格批注信息

 Sub x5()
    [B24] = Range("I2").Comment.Text
 End Sub

6 单元格的位置信息

 Sub x6()
    With Range("b3")
      [b26] = .Top
      [b27] = .Left
      [b28] = .Height
      [b29] = .Width
    End With
 End Sub

7 单元格的上级信息

Sub x7()
  With Range("b3")
    [b31] = .Parent.Name
    [b32] = .Parent.Parent.Name
  End With
End Sub

8 内容判断

  Sub x8()
   With Range("i3")
    [b34] = .HasFormula
    [b35] = .Hyperlinks.Count
   End With
  End Sub

四、单元格的数字格式

1.判断数值的格式

（1） 判断是否为空单元格

Sub d1()
   [b1] = ""
   If Range("a1") = "" Then
   If Len([a1]) = 0 Then
   If VBA.IsEmpty([a1]) Then
      [b1] = "空值"
    End If
End Sub

（2） 判断是否为数字

Sub d2()
  [b2] = ""
  If VBA.IsNumeric([a2]) And [a2] <> "" Then
  If Application.WorksheetFunction.IsNumber([a2]) Then
    [b2] = "数字"
  End If
End Sub

（3） 判断是否为文本

Sub d3()
  [b3] = ""
  If Application.WorksheetFunction.IsText([A3]) Then
   If VBA.TypeName([a3].Value) = "String" Then
     [b3] = "文本"
  End If
End Sub

（4） 判断是否为汉字

 Sub d4()
    [b4] = ""
    If [a4] > "z" Then
      [b4] = "汉字"
    End If
 End Sub

（5） 判断错误值

Sub d10()
  [b5] = ""
  If VBA.IsError([a5]) Then
  If Application.WorksheetFunction.IsError([a5]) Then
     [b5] = "错误值"
  End If
End Sub
 Sub d11()
  [b6] = ""
  If VBA.IsDate([a6]) Then
     [b6] = "日期"
  End If
End Sub

2.设置单元格自定义格式

 Sub d30()
    Range("d1:d8").NumberFormatLocal = "0.00"
 End Sub

3.按指定格式从单元格返回数值

Format函数语法(和工作表数Text用法基本一致)

Format(数值,自定义格式代码)

五、设置Excel中的颜色

Excel中的颜色可以用两种方式获取，一种是EXCEL内置颜色，另一种是利用QBCOLOR函数返回

Sub y1()
     Dim x As Integer
    Range("a1:b60").Clear
    For x = 1 To 56
          Range("a" & x) = x
          Range("b" & x).Font.ColorIndex = 3
    Next x
End Sub

 Sub y2()
      Dim x As Integer
     For x = 0 To 15
        Range("d" & x + 1) = x
        Range("e" & x + 1).Interior.Color = QBColor(x)
     Next x
 End Sub

Sub y3()
      Dim 红 As Integer, 绿 As Integer, 蓝 As Integer
              红 = 255
              绿 = 123
              蓝 = 100
      Range("g1").Interior.Color = RGB(红, 绿, 蓝)
End Sub

六、单元格合并

1.单元格合并

Sub h1()    
      Range("g1:h3").Merge    
End Sub

2.合并区域的返回信息

Sub h2()   
     Range("e1") = Range("b3").MergeArea.Address         ' 返回单元格所在的合并单元格区域   
End Sub

3.判断是否含合并单元格

Sub h3()
     MsgBox Range("b2").MergeCells
     MsgBox Range("A1:D7").MergeCells
    Range("e2") = IsNull(Range("a1:d7").MergeCells)
    Range("e3") = IsNull(Range("a9:d72").MergeCells)
End Sub

4.综合示例

合并H列相同单元格

 Sub h4()
  Dim x As Integer
  Dim rg As Range
  Set rg = Range("h1")
   Application.DisplayAlerts = False
  For x = 1 To 13
    If Range("h" & x + 1) = Range("h" & x) Then
      Set rg = Union(rg, Range("h" & x + 1))
    Else
     
       rg.Merge
      
      Set rg = Range("h" & x + 1)
    End If
  Next x
  Application.DisplayAlerts = True
 End Sub

七、单元格输入

1 单元格输入

Sub t1()
  Range("a1") = "a" & "b"
  Range("b1") = "a" & Chr(10) & "b"          换行答输入
End Sub

2 单元格复制和剪切

  Sub t2()
    Range("a1:a10").Copy Range("c1")          A1：A10的内容复制到C1
  End Sub

  Sub t3()
    Range("a1:a10").Copy
    ActiveSheet.Paste Range("d1")             粘贴至D1
  End Sub
  
  Sub t4()
    Range("a1:a10").Copy
    Range("e1").PasteSpecial (xlPasteValues)       只粘贴为数值
  End Sub
  
  Sub t5()
    Range("a1:a10").Cut
    ActiveSheet.Paste Range("f1")                  粘贴到f1
  End Sub

  Sub t6()
    Range("c1:c10").Copy
    Range("a1:a10").PasteSpecial Operation:=xlAdd          选择粘贴-加
  End Sub
  
  Sub T7()
      Range("G1:G10") = Range("A1:A10").Value
  End Sub

3 填充公式

Sub T8()
  Range("b1") = "=a1*10"
  Range("b1:b10").FillDown                     向下填充公式
End Sub

4.插入行并复制公式

（1）插入行

Sub c1()
    Rows(4).Insert
End Sub

（2）插入行并复制公式

Sub c2()                      '插入行并复制公式
        Rows(4).Insert
        Range("3:4").FillDown
      Range("4:4").SpecialCells(xlCellTypeConstants) = ""
End Sub

（3）如不相同，则插入一行

Sub c3()
      Dim x As Integer
      For x = 2 To 20
      If Cells(x, 3) <> Cells(x + 1, 3) Then
            Rows(x + 1).Insert
        x = x + 1
    End If
  Next x
End Sub

（4）相同部门插入小计汇总

Sub c4()
  Dim x As Integer, m1 As Integer, m2 As Integer
  Dim k As Integer
  m1 = 2
  For x = 2 To 1000
      If Cells(x, 1) = "" Then Exit Sub
      If Cells(x, 3) <> Cells(x + 1, 3) Then
          m2 = x
          Rows(x + 1).Insert
          Cells(x + 1, "c") = Cells(x, "c") & " 小计"
          Cells(x + 1, "h") = "=sum(h" & m1 & ":h" & m2 & ")"
          Cells(x + 1, "h").Resize(1, 4).FillRight
          Cells(x + 1, "i") = ""
          x = x + 1
          m1 = m2 + 2
      End If
 Next x
End Sub

（5）删除小计行

Sub dd() 删除小计行
     Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

八、单元格查询

1 使用循环查找 (在单元格中查找效率太低)

2 调用工作表函数

Sub c1() 判断是否存在,并查找所在行数
  Dim hao As Integer
  Dim icount As Integer
  icount = Application.WorksheetFunction.CountIf(Sheets("库存明细表").[b:b], [g3])
  If icount > 0 Then
   MsgBox "该入库单号码已经存在，请不要重复录入"
   MsgBox Application.WorksheetFunction.Match([g3], Sheets("库存明细表").[b:b], 0)
  End If
End Sub

3 使用Find方法

Sub c2()
  Dim r As Integer, r1 As Integer
  Dim icount As Integer
  icount = Application.WorksheetFunction.CountIf(Sheets("库存明细表").[b:b], [g3])
  If icount > 0 Then
   r = Sheets("库存明细表").[b:b].Find(Range("G3"), Lookat:=xlWhole).Row 查找号码第一次出现的位置
   r1 = Sheets("库存明细表").[b:b].Find([g3], , , , , xlPrevious).Row
   MsgBox r & ":" & r1
  End If
End Sub

4 返回最下一行非空行的行数

 Sub c3() 返回最下一行非空行的行数    
  MsgBox Sheets("库存明细表").Cells.Find("*", , , , , xlPrevious).Row    
 End Sub

5 入库单查询实例

Sub 输入()
      Dim c As Integer   '号码在库存表中的个数
      Dim r As Integer   '入库单的数据行数
      Dim cr As Integer  '库存明细表中第一个空行的行数
      With Sheets("库存明细表")
      c = Application.CountIf(.[b:b], Range("g3"))
      If c > 0 Then
             MsgBox "该单据号码已经存在！,请不要重复录入"
       Exit Sub
      Else
           r = Application.CountIf(Range("b6:b10"), "<>")
           cr = .[b65536].End(xlUp).Row + 1
                   .Cells(cr, 1).Resize(r, 1) = Range("e3")
                   .Cells(cr, 2).Resize(r, 1) = Range("g3")
                   .Cells(cr, 3).Resize(r, 1) = Range("c3")
                   .Cells(cr, 4).Resize(r, 6) = Cells(6, 2).Resize(r, 6).Value
           MsgBox "输入已完成"
      End If
     End With
End Sub


Sub 查找()
      Dim c As Integer   '号码在库存表中的个数
      Dim r As Integer   '入库单的数据行数  
      With Sheets("库存明细表")
        c = Application.CountIf(.[b:b], Range("g3"))
        If c = 0 Then
               MsgBox "该单据号码不存在！"
         Exit Sub
        Else
         r = .[b:b].Find(Range("g3"), , , , , xlNext).Row
        Range("c3") = .Cells(r, 3)
        Range("e3") = .Cells(r, 1)
        Cells(6, 2).Resize(c, 5) = .Cells(r, 4).Resize(c, 5).Value
       MsgBox "查询已完成"
       End If
     End With
End Sub

Sub 删除()
     Dim c As Integer   '号码在库存表中的个数
    Dim r As Integer   '入库单的数据行数  
    With Sheets("库存明细表")
            c = Application.CountIf(.[b:b], Range("g3"))
            If c = 0 Then
                     MsgBox "该单据号码不存在！"
           Exit Sub
            Else
                  r = .[b:b].Find(Range("g3"), , , , , xlNext).Row
                        .Range(r & ":" & c + r - 1).Delete
                 MsgBox "删除已完成"
          End If
   End With
 End Sub

Sub 修改()
    Call 删除
    Call 输入
End Sub

<br />

---

<br />

CH7 EXCEL事件

单元格发生变动时提醒
worksheet selectionchange
加入代码
private sub worksheet.change(byval target as range)
msgbox target.address &"单元格的值被改为"&target.value
<br />

---

<br />

CH8 数组

一、VBA数组概念

1、什么是VBA数组呢？

VBA数组就是储存一组数据的数据空间?数据类型可以数字,可以是文本,可以是对象,也可以是VBA数组.

2 VBA数组存在形态

VBA数组是以变量形式存放的一个空间,它也有行有列，也可以是三维空间。

1. 常量数组
   array(1,2)
   array(array(1,2,4),array("a","b","c"))
2. 静态数组
   x(4) 有5个位置，编号从0~4
   arr(1 to 10) 有10个位置，编号1~10
   arr(1 to 10,1 to 2) 10行2列的空间，总共20个位置，这是二维数组
   arr(1 to 10,1 to 2,1 to 3) 三维数组，总1023=60个位置。这是三维数组
   3)动态数组
   arr() 不知道有多少行多少列

二、数组的读取

1.VBA数组写入

1）按编号(标)写入和读取

 Sub t1()     写入一维数组
 Dim x As Integer
 Dim arr(1 To 10)
 arr(2) = 190
 arr(10) = 5
 End Sub

Sub t2()     向二维数组写入数据和读取
 Dim x As Integer, y As Integer
 Dim arr(1 To 5, 1 To 4)
 For x = 1 To 5
   For y = 1 To 4
     arr(x, y) = Cells(x, y)
   Next y
 Next x
MsgBox arr(3, 1)
End Sub

2）动态数组

   Sub t3()
    Dim arr()
    Dim row
    row = Sheets("sheet2").Range("a65536").End(xlUp).row - 1
    ReDim arr(1 To row)
    For x = 1 To row
       arr(x) = Cells(x, 1)
    Next x
    Stop
   End Sub

3）批量写入

  Sub t4()     由常量数组导入
  Dim arr
  arr = Array(1, 2, 3, "a")
  Stop
  End Sub

 Sub t5()     由单元格区域导入
   Dim arr
   arr = Range("a1:d5")
   Stop
 End Sub

2.数组的读取

1）在内存中读取
在内存中读取后用于继续运算，直接用下面的格式
数组变量(5)
数组变量(3,2)
例:

    Sub d1()
     Dim arr, arr1()
     Dim x As Integer, k As Integer, m As Integer
     arr = Range("a1:a10")     把单元格区域导入内存数组中
     m = Application.CountIf(Range("a1:a10"), ">10")     计算大于10的个数
     ReDim arr1(1 To m)
     For x = 1 To 10
       If arr(x, 1) > 10 Then
          k = k + 1
          arr1(k) = arr(x, 1)
       End If
     Next x
    End Sub

2）读取存入单元格中

  Sub d2()     二维数组存入单元格
    Dim arr, arr1(1 To 5, 1 To 1)
    Dim x As Integer
    arr = Range("b2:c6")
    For x = 1 To 5
      arr1(x, 1) = arr(x, 1) * arr(x, 2)
    Next x
    Range("d2").Resize(10) = arr1
  End Sub
  
  Sub d3()     一维数组存入单元格
    Dim arr, arr1(1 To 5)
    Dim x As Integer
    arr = Range("b2:c6")
    For x = 1 To 5
      arr1(x) = arr(x, 1) * arr(x, 2)
    Next x
        Range("a13").Resize(1, 5) = arr1
    Range("d2").Resize(5) = Application.Transpose(arr1)
  End Sub
   
  Sub d4()     数组部分存入
    Dim arr, arr1(1 To 10000, 1 To 1)
    Dim x As Integer
    arr = Range("b2:c6")
    For x = 1 To 5
      arr1(x, 1) = arr(x, 1) * arr(x, 2)
    Next x
    Range("d2").Resize(5) = arr1
  End Sub

三、数组的空间

1、数组的大小

数组是用编号排序的，那么如何获得一个数组的大小呢

Lbound(数组) 可以获取数组的最小下标(编号)
Ubound(数组) 可以获取数组的最大上标(编号)
Ubound(数组,1) 可以获得数组的行方面(第1维)最大上标
Ubound(数组,2) 可以获得数组的列方向(第2维)的最大上标

Sub d6()
    Dim arr
    Dim k, m
    arr = Range("a2:d5")
    For x = 1 To UBound(arr, 1)

    Next x
End Sub

2、动态数组的动态扩充

如果一个数组无法或不方便计算出总的大小，而在一些特殊情况下又不允许有空位。这时我们就需要用动态的导入方法

ReDim Preserve arr() 可以声明一个动态大小的数组，而且可以保留原来的数值，就相当于厂房小了，可以改扩建增大，但是它只能 让最未维实现动态，如果是一维不存在最未维，只有一维

 （1）扩充方式1
Sub d7()
Dim arr, arr1()
 arr = Range("a1:d6")
 Dim x, k
 For x = 1 To UBound(arr)
  If arr(x, 1) = "B" Then
     k = k + 1
     ReDim Preserve arr1(1 To 4, 1 To k)
     arr1(1, k) = arr(x, 1)
     arr1(2, k) = arr(x, 2)
     arr1(3, k) = arr(x, 3)
     arr1(4, k) = arr(x, 4)
  End If
 Next x
Range("a8").Resize(k, 4) = Application.Transpose(arr1)
End Sub

（2）方式二：申明足够大的数组
Sub d8()
Dim arr, arr1(1 To 100000, 1 To 4)
arr = Range("a1:d6")
Dim x, k
For x = 1 To UBound(arr)
If arr(x, 1) = "B" Then
k = k + 1
arr1(k, 1) = arr(x, 1)
arr1(k, 2) = arr(x, 2)
arr1(k, 3) = arr(x, 3)
arr1(k, 4) = arr(x, 4)
End If
Next x
Range("a15").Resize(k, 4) = arr1
End Sub

3 清空数组

清空数组使用erase语句

Sub d9()
Dim arr, arr1(1 To 1000, 1 To 1)
Dim x, m, k
arr = Range("a1:a16")
For x = 1 To UBound(arr)
 If arr(x, 1) <> "" Then
    k = k + 1
    arr1(k, 1) = arr(x, 1)
 Else
    m = m + 1
    Range("c1").Offset(0, m).Resize(k) = arr1
    Erase arr1
    k = 0
 End If
Next x
End Sub

四、可以生成数组的函数

1、split函数

按分隔符把字符串截取成VBA数组,该数组是一维数组，编号从0开始

split(字符串,分隔符)

Sub t1()
  Dim sr, arr
  sr = "A-BC-FGR-H"
  arr = VBA.Split(sr, "-")
  MsgBox Join(arr, ",")
End Sub

2、Filter函数：只能模糊匹配

按条件筛选符合条件的值组成一个新的数组

Filter(数组,筛选条件,是/否)

注：如果是（true）则返回包含的数组，如果否则返回非包含的数组

Sub t2()
 Dim arr, arr1, arr2
 arr = Application.Transpose(Range("A2:A10"))
 arr1 = VBA.Filter(arr, "W", True)
 arr2 = VBA.Filter(arr, "W", False)
 Range("B2").Resize(UBound(arr1) + 1) = Application.Transpose(arr1)
 Range("C2").Resize(UBound(arr2) + 1) = Application.Transpose(arr2)
End Sub

3、index函数：

调用该工作表函数可以把二维数组的某一列或某一行截取出来，构成一个新的数组。
Application.Index(二维数组,0,列数)) 返回二维数组
Application.Index(二维数组,行数,0)) 返回一维数组

Sub t3()
 Dim arr, arr1, arr2
  arr = Range("a2:d6")
  arr1 = Application.Index(arr, , 1)
  arr2 = Application.Index(arr, 4, 0)
  Stop
End Sub

4、vlookup函数

Vlookup函数的第一个参数可以用VBA数组，返回的也是一个VBA数组

Sub t4()
Dim arr, arr1
  arr = Range("a2:d6")
  arr1 = Application.VLookup(Array("B", "C"), arr, 4, 0)
End Sub

5 Sumif函数和Countif函数

Countif和sumif函数的第二个参数都可以使用数组，所以也可以返回一个VBA数组，如：

 Sub t5()
 Dim T
 T = Timer
   Dim arr
   arr = Application.SumIf(Range("a2:a10000"), Array("B", "C", "G", "R"), Range("B2:B10000"))
 MsgBox Timer - T
 Stop
 End Sub

Sub t55()
 Dim T
 T = Timer
  Dim arr, arr1(1 To 4, 1 To 2), x
  arr1(1, 1) = "B"
  arr1(2, 1) = "C"
  arr1(3, 1) = "G"
  arr1(4, 1) = "R"
 
  For x = 2 To 10000
     Select Case Cells(x, 1)
     Case "B"
        arr1(1, 2) = arr1(1, 2) + Cells(x, 2)
     Case "C"
        arr1(2, 2) = arr1(2, 2) + Cells(x, 2)
     Case "G"
        arr1(3, 2) = arr1(3, 2) + Cells(x, 2)
     Case "R"
        arr1(4, 2) = arr1(4, 2) + Cells(x, 2)
     End Select
  Next x
 MsgBox Timer - T
End Sub    

五、单元格格式

1.金额大于500填上红色

Sub 单元格循环()
Dim x As Integer
Dim t
清除颜色
t = Timer
For x = 2 To Range("a65536").End(xlUp).Row
    If Range("d" & x) > 500 Then
       Range(Cells(x, 1), Cells(x, 4)).Interior.ColorIndex = 3
   End If
Next x
MsgBox Timer - t
End Sub

2.清除颜色

Sub 清除颜色()
  Range("a:d").Interior.ColorIndex = xlNone
End Sub

3.数组方法1

Sub 数组方法()
 Dim arr, t
 Dim x As Integer
 Dim sr As String, sr1 As String
 清除颜色
  t = Timer
  arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
 For x = 1 To UBound(arr)
      If x = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
          If arr(x, 1) > 500 Then
              sr1 = sr
              sr = sr & "A" & x + 1 & ":D" & x + 1 & ","
         If Len(sr) > 255 Then
                sr = sr1
                Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
                 sr = ""
        End If
   End If
 Next x
MsgBox Timer - t
End Sub

4.数组方法2

Sub 数组方法2()
Dim arr, t
Dim x As Integer, x1 As Integer
Dim sr As String, sr1 As String
清除颜色
t = Timer
arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
      If x = UBound(arr) Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
           If arr(x, 1) > 500 Then
               sr1 = sr
               x1 = x + 1
               Do
                     x = x + 1
               Loop Until arr(x, 1) <= 500      
     sr = sr & "A" & x1 & ":D" & x & ","
  If Len(sr) > 255 Then
    sr = sr1
    x = x1 - 1
    Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
    sr = ""
  End If
  x = x - 1
End If
Next x
MsgBox Timer - t
End Sub

5.数组方法3

Sub 数组方法3()
    Dim arr, t
    Dim x As Integer, x1 As Integer
    Dim sr As String, sr1 As String
   清除颜色
   t = Timer
  arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
  For x = 1 To UBound(arr)
  If x = UBound(arr) Then Application.Intersect(Range("a:d"), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 3
       If arr(x, 1) > 500 Then
        sr1 = sr
       x1 = x + 1
      Do
           x = x + 1
     Loop Until arr(x, 1) <= 500      
     sr = sr & x1 & ":" & x & ","
     If Len(sr) > 255 Then
          sr = sr1
         x = x1 - 1
        Application.Intersect(Range("a:d"), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 3
        sr = ""
     End If
  x = x - 1
 End If
 Next x
 MsgBox Timer - t
End Sub

Option Explicit
'数组也可以设置格式？
'数组除了数字类型外，当然没有颜色、字体等格式，但是别忘了range对象可以表示多个连续或不连续的单元格区域
'利用上述特点，我们就是要数组构造单元格地址串，然后批量对单元格进行格式设置。
'注意，单元格地址串不能>255，所以如果单元格操作过多，我们还需要分次分批设置单元格格式

Sub 填充颜色()
 Range("a2:d2,a7:d7,a10:d10").Interior.ColorIndex = 3
End Sub

六、数组函数补充

1 数组的最值

 Sub s()
 Dim arr1()
 
arr1 = Array(1, 12, 4, 5, 19)
 
MsgBox "1, 12, 4, 5, 19最大值" & Application.Max(arr1)
 MsgBox "1, 12, 4, 5, 19最小值:" & Application.Min(arr1)
 MsgBox "1, 12, 4, 5, 19第二大值：" & Application.Large(arr1, 2)
 MsgBox "1, 12, 4, 5, 19第二小值：" & Application.Small(arr1, 2)
 
End Sub

2、求和

 用application.Sum (数组)

3 统计个数

counta和count函数可以统计VBA数组的数字个数及所有已填充内容的个数

 Sub s1()
  
  Dim arr1, arr2(0 To 10), x
  arr1 = Array("a", "3", "", 4, 6)
  For x = 0 To 4
    arr2(x) = arr1(x)
  Next x
  
  MsgBox "数组1的数字个数：" & Application.Count(arr2)
  
  MsgBox "数组2的已填充数值的个数" & Application.CountA(arr2)
  
  End Sub

4 在数组里查找

  Sub s2()
   Dim arr
   On Error Resume Next
   arr = Array("a", "c", "b", "f", "d")
   MsgBox Application.Match("f", arr, 0)
  If Err.Number = 13 Then
     MsgBox "查找不到"
   End If
  End Sub  

二、数组函数

1、split函数

 '按分隔符把字符串截取成VBA数组,该数组是一维数组，编号从0开始

 'split(字符串,分隔符)

Sub t1()
  Dim sr, arr
  sr = "A-BC-FGR-H"
  arr = VBA.Split(sr, "-")
  MsgBox Join(arr, ",")
End Sub

2、Filter函数：

 '按条件筛选符合条件的值组成一个新的数组

 'Filter(数组,筛选条件,是/否)
 
 '注：如果是（true）则返回包含的数组，如果否则返回非包含的数组
Sub t2()
 Dim arr, arr1, arr2
 arr = Application.Transpose(Range("A2:A10"))
 arr1 = VBA.Filter(arr, "W", True)
 arr2 = VBA.Filter(arr, "W", False)
 Range("B2").Resize(UBound(arr1) + 1) = Application.Transpose(arr1)
 Range("C2").Resize(UBound(arr2) + 1) = Application.Transpose(arr2)
End Sub

3、index函数：

'调用该工作表函数可以把二维数组的某一列或某一行截取出来，构成一个新的数组。

' Application.Index(二维数组,0,列数)) 返回二维数组
  ' Application.Index(二维数组,行数,0)) 返回一维数组
 Sub t3()
  Dim arr, arr1, arr2

   arr = Range("a2:d6")
   arr1 = Application.Index(arr, , 1)
   arr2 = Application.Index(arr, 4, 0)
   Stop
 End Sub

4、vlookup函数

  'Vlookup函数的第一个参数可以用VBA数组，返回的也是一个VBA数组

    Sub t4()
    Dim arr, arr1
      arr = Range("a2:d6")
      arr1 = Application.VLookup(Array("B", "C"), arr, 4, 0)
    End Sub

5 Sumif函数和Countif函数

 'Countif和sumif函数的第二个参数都可以使用数组，所以也可以返回一个VBA数组，如：

 Sub t5()
     Dim T
     T = Timer
       Dim arr
       arr = Application.SumIf(Range("a2:a10000"), Array("B", "C", "G", "R"), Range("B2:B10000"))
     MsgBox Timer - T
     Stop
     End Sub

   Sub t55()
     Dim T
     T = Timer
      Dim arr, arr1(1 To 4, 1 To 2), x
      arr1(1, 1) = "B"
      arr1(2, 1) = "C"
      arr1(3, 1) = "G"
      arr1(4, 1) = "R"
     ' arr = Range("a1:d10000")
      For x = 2 To 10000
         Select Case Cells(x, 1)
         Case "B"
            arr1(1, 2) = arr1(1, 2) + Cells(x, 2)
         Case "C"
            arr1(2, 2) = arr1(2, 2) + Cells(x, 2)
         Case "G"
            arr1(3, 2) = arr1(3, 2) + Cells(x, 2)
         Case "R"
            arr1(4, 2) = arr1(4, 2) + Cells(x, 2)
         End Select
      Next x
     MsgBox Timer - T
   End Sub

七、VBA排序算法

1.插入排序

Sub 插入排序()
Dim arr, temp, x, y, t, iMax, k, k1, k2
     t = Timer
    arr = Range("a1:a10")
    For x = 1 + 1 To UBound(arr)  
    temp = arr(x, 1)     记得要插入的值     
    For y = x - 1 To 1 Step -1
   If arr(y, 1) <= temp Then Exit For
   arr(y + 1, 1) = arr(y, 1)
       k1 = k1 + 1
   Next y
   arr(y + 1, 1) = temp
         k2 = k2 + 1
  Next
     Range("d3").Resize(UBound(arr)) = ""
     Range("d3").Resize(UBound(arr)) = arr
     Range("d2") = Timer - t
     MsgBox k1
End Sub

Sub 插入排序单元格演示()
     On Error Resume Next
    Dim arr, temp, x, y, t, iMax, k
    For x = 2 To 10  
        temp = Cells(x, 1)     记得要插入的值
                 Range("A" & x).Interior.ColorIndex = 3
       For y = x - 1 To 1 Step -1
               Range("A" & y).Interior.ColorIndex = 4
        If Cells(y, 1) <= temp Then Exit For
               Cells(y + 1, 1) = Cells(y, 1)
               Range("A" & y).Interior.ColorIndex = xlNone
       Next y
       Cells(y + 1, 1) = temp
           Range("A" & y).Interior.ColorIndex = xlNone
           Range("A" & x).Interior.ColorIndex = xlNone
   Next
End Sub

2.快速排序

Sub dd()
Dim arr1(0 To 4999) As Long, arr, x, t
t = Timer
arr = Range("a1:a5000")
For x = 1 To 5000
  arr1(x - 1) = arr(x, 1)
Next x
QuickSort arr1()
Range("f2") = Timer - t
 End Sub 

Public Sub QuickSort(ByRef lngArray() As Long)
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Long
    Dim iOuter As Long
    Dim iMax As Long
             iLBound = LBound(lngArray)
            iUBound = UBound(lngArray)     
            If (iUBound - iLBound) Then
                For iOuter = iLBound To iUBound   
            If lngArray(iOuter) > lngArray(iMax) Then iMax = iOuter
                  Next iOuter
                   iTemp = lngArray(iMax)
                  lngArray(iMax) = lngArray(iUBound)
                  lngArray(iUBound) = iTemp            开始快速排序
                  InnerQuickSort lngArray, iLBound, iUBound
            End If
        R ange("f3").Resize(5000) = Application.Transpose(lngArray)
    End Sub



Private Sub InnerQuickSort(ByRef lngArray() As Long, ByVal iLeftEnd As Long, ByVal iRightEnd As Long)

Dim iLeftCur As Long

Dim iRightCur As Long

Dim iPivot As Long

Dim iTemp As Long



If iLeftEnd >= iRightEnd Then Exit Sub



iLeftCur = iLeftEnd

iRightCur = iRightEnd + 1

iPivot = lngArray(iLeftEnd)  

Do
    Do
        iLeftCur = iLeftCur + 1
    Loop While lngArray(iLeftCur) < iPivot       

    Do

        iRightCur = iRightCur - 1
    Loop While lngArray(iRightCur) > iPivot       

    If iLeftCur >= iRightCur Then Exit Do              
   交换值
    iTemp = lngArray(iLeftCur)
    lngArray(iLeftCur) = lngArray(iRightCur)
    lngArray(iRightCur) = iTemp
Loop  

    递归快速排序
lngArray(iLeftEnd) = lngArray(iRightCur)
lngArray(iRightCur) = iPivot
InnerQuickSort lngArray, iLeftEnd, iRightCur - 1
InnerQuickSort lngArray, iRightCur + 1, iRightEnd
End Sub

3.冒泡排序

Sub 冒泡排序()
   Dim arr, temp, x, y, t, k
   t = Timer
   arr = Range("a1:a10")
   For x = 1 To UBound(arr) - 1
         For y = x + 1 To UBound(arr)     只和当前数字下面的数进行比较
             If arr(x, 1) > arr(y, 1) Then     如果它大于它下面某一个数字
                     temp = arr(x, 1)
                     arr(x, 1) = arr(y, 1)
                     arr(y, 1) = temp
             End If
   
         Next y
     Next x
     Range("b3").Resize(x) = ""
     Range("b3").Resize(x) = arr
             Range("b2") = Timer - t
     MsgBox k
End Sub


Sub 冒泡排序演示()
     Dim arr, temp, x, y, t, k
     For x = 1 To 9
                Range("a" & x).Interior.ColorIndex = 3
     For y = x + 1 To 10      只和当前数字下面的数进行比较
                     Range("a" & y).Interior.ColorIndex = 4
     If Cells(x, 1) > Cells(y, 1) Then     如果它大于它下面某一个数字
           temp = Cells(x, 1)
           Cells(x, 1) = Cells(y, 1)
           Cells(y, 1) = temp
     End If
                     Range("a" & y).Interior.ColorIndex = xlNone
     Next y
                     Range("a" & x).Interior.ColorIndex = xlNone                         
     Next x
End Sub

4.希尔排序

Sub 希尔排序()
    Dim arr
    Dim 总大小, 间隔, x, y, temp, t
    t = Timer
    arr = Range("a1:a30")
    总大小 = UBound(arr) - LBound(arr) + 1
    间隔 = 1
    If 总大小 > 13 Then
             Do While 间隔 < 总大小
                   间隔 = 间隔 * 3 + 1
             Loop
             间隔 = 间隔  9
    End If
      Stop
    Do While 间隔
           For x = LBound(arr) + 间隔 To UBound(arr)
            temp = arr(x, 1)
          For y = x - 间隔 To LBound(arr) Step -间隔
                     If arr(y, 1) <= temp Then Exit For
                       arr(y + 间隔, 1) = arr(y, 1)
                               k1 = k1 + 1
          Next y
                  arr(y + 间隔, 1) = temp
                   Next x
                  间隔 = 间隔  3
           Loop
                   MsgBox k1
                   Range("e3").Resize(5000) = ""
                  Range("d1").Resize(UBound(arr)) = arr
                           Range("e2") = Timer - t
  End Sub
Sub 打乱顺序()
     Dim arr, temp, x
     arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
     For x = 1 To UBound(arr)
           num = Int(Rnd() * UBound(arr) + 1)
           temp = arr(num, 1)
           arr(num, 1) = arr(x, 1)
           arr(x, 1) = temp
     Next x
     Range("a1").Resize(x - 1) = arr
 End Sub
     Sub 希尔排序单元格演示()
       Dim arr
       Dim 总大小, 间隔, x, y, temp, t
       t = Timer
       arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
       总大小 = UBound(arr) - LBound(arr) + 1
       间隔 = 1
       If 总大小 > 13 Then
          Do While 间隔 < 总大小
            间隔 = 间隔 * 3 + 1
          Loop
          间隔 = 间隔  9
       End If
           Stop
       Do While 间隔
          For x = LBound(arr) + 间隔 To UBound(arr)
           temp = Cells(x, 1)
           Range("a" & x).Interior.ColorIndex = 3
           For y = x - 间隔 To LBound(arr) Step -间隔
               Range("a" & y).Interior.ColorIndex = 6
              If Cells(y, 1) <= temp Then Exit For
              Cells(y + 间隔, 1) = Cells(y, 1)
                  k1 = k1 + 1
           Next y
           Cells(y + 间隔, 1) = temp
           Range("a1:a30").Interior.ColorIndex = xlNone
          Next x
         间隔 = 间隔  3
        Loop
            MsgBox k1
            Range("e3").Resize(5000) = ""
             Range("d1").Resize(UBound(arr)) = arr
            Range("e2") = Timer - t
     End Sub

5.选择排序

     Sub 选择排序()
       Dim arr, temp, x, y, t, iMax, k, k1, k2
       t = Timer
       arr = Range("a1:a10")
       For x = UBound(arr) To 1 + 1 Step -1
          iMax = 1     最大的索引
          For y = 1 To x
               If arr(y, 1) > arr(iMax, 1) Then iMax = y
          Next y
          temp = arr(iMax, 1)
          arr(iMax, 1) = arr(x, 1)
          arr(x, 1) = temp
       Next x  
           Range("c3").Resize(UBound(arr)) = ""
           Range("c3").Resize(UBound(arr)) = arr
           Range("c2") = Timer - t
           MsgBox k1
     End Sub

     Sub 选择排序单元格演示()
       Dim arr, temp, x, y, t, iMax, k, k1, k2
       For x = 10 To 2 Step -1
          iMax = 1
                            Range("a" & x).Interior.ColorIndex = 3
          For y = 1 To x
                            Range("a" & y).Interior.ColorIndex = 4
               If Cells(y, 1) > Cells(iMax, 1) Then
                            Range("a" & iMax).Interior.ColorIndex = xlNone
                iMax = y
               End If
                            Range("a" & y).Interior.ColorIndex = xlNone
                            Range("a" & iMax).Interior.ColorIndex = 6                       
          Next y
          temp = Cells(iMax, 1)
          Cells(iMax, 1) = Cells(x, 1)
          Cells(x, 1) = temp
          Range("a" & x).Interior.ColorIndex = xlNone
          Range("a" & iMax).Interior.ColorIndex = xlNone
       Next x
     End Sub

<br />

---

<br />

CH9 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-确定

二、VBA字典的使用

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

5.区分大小写

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

四、字典与求和

      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

六、字典综合算法

1.多列汇总

     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

2.多条件多列汇总

     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

3.数据透视表式汇总

     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