VBABACK

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=1https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=2
第1部分Range（单元格）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧1 单元格的引用方法

#REGEXP

 

Set reg = CreateObject("VBScript.RegExp")

'Dim reg As New RegExp

Dim sr wlist = "[あいうえおかきくけこさしすせそたちつてとなにぬねのはひふへほまみむめやり]" sr = "A12d我A爱56あい你 A4" With regx .Global = True ' .Pattern = "[\u4e00-\u9fa5]|\s" .Pattern = wlist End With

 

 

 

Sub t()
'Dim reg As New RegExp
Dim cell As Range
Set reg = CreateObject("VBScript.RegExp")

With reg
.Global = True
.Pattern = ".*(20\d{2})\D?(\d{1,2})\D?(\d{1,2}).*"
'.Pattern = ".*(20\d{2})"
For Each cell In Range(Range("a2"), Range("a2").End(xlDown))
 'If .test(cell) Then MsgBox "字符串中含有数字"

' If .test(cell) Then
 If .test(cell) Then
   cell.Offset(0, 1) = .Replace(cell, "$1/$2*$3")
 End If
Next
End With

End Sub
    Cells(x, 3) = .Execute(sr)(0)

#Execute

 Set reg = CreateObject("VBScript.RegExp") Sub z3() Dim sr sr = "89.90美元" Debug.Print Val(sr) End Sub 

#Replace
Sub t3()
    Dim reg As New RegExp
    Dim sr
    sr = "ABCEA"
    With reg
     .Global = True
     .Pattern = "A"
     Debug.Print .Replace(sr, "")
    End With
End Sub

#Execute
Option Explicit
Sub 按钮1_单击()
Dim regx As New RegExp
Dim sr, x, mat, m
For x = 2 To Range("a65536").End(xlUp).Row
sr = Cells(x, 1)
With regx
.Global = True
.Pattern = Cells(x, 2)
If Cells(x, 5) = 1 Then
Cells(x, 3) = .Replace(sr, "")
Else
If .test(sr) = False Then
Cells(x, 3) = "没有匹配的"
Else
Cells(x, 3) = .Execute(sr)(0)
End If
End If
End With
Next x
End Sub

#Text方法
'返回一个布尔值，该值指示正则表达式是否与字符串成功匹配。其实就是判断两个字符串是否匹配成功
Sub t7()
Dim reg As New RegExp
Dim sr
sr = "BCR6EA"
With reg
 .Global = True
 .Pattern = "\d+"
 If .test(sr) Then MsgBox "字符串中含有数字"
End With
End Sub

 

#DICT

Dim d, k  

Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens" 
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
k=d.Keys
[B1].Resize(d.Count,1)=Application.Transpose(k)
k=d.Keys：把字典中存在的所有的关键字赋给变量k。得到的是一个一维数组，下限为0，上限为d.Count-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(0)
MsgBox D.Keys(1)
MsgBox D.Keys(2)
MsgBox D.Items(0)
'Stop
End Sub

Dim d 
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens" 
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
d.Remove(“b”)
Remove方法：object.Remove(key )
Remove 方法从一个 Dictionary 对象中清除一个关键字，项目对。实例说明：
d.Remove(“b”)：清除字典中”b”关键字和与它对应的项。清除之后,现在字典里只有2个关键字了。
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

    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
    
    ★★★★★★★★★★★★★★★
    Option Explicit
    
    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
    
     

 

#ADODB

Sub CopyData_5()
  Dim Sql As String
  Dim j As Integer
  Dim R As Integer
  Dim Cnn As ADODB.Connection
 Dim rs As ADODB.Recordset
 With Sheet5
  .Cells.Clear
  Set Cnn = New ADODB.Connection
  With Cnn
   .Provider = "microsoft.jet.oledb.4.0"
   .ConnectionString = "Extended Properties=Excel 8.0;" _
    & "Data Source=" & ThisWorkbook.Path & "\数据表"
   .Open
  End With
  Set rs = New ADODB.Recordset
  Sql = "select * from [Sheet1$]"
  rs.Open Sql, Cnn, adOpenKeyset, adLockOptimistic
   For j = 0 To rs.Fields.Count - 1
        .Cells(1, j + 1) = rs.Fields(j).Name
      Next
    R = .Range("A65536").End(xlUp).Row
    .Range("A" & R + 1).CopyFromRecordset rs
  End With
  rs.Close
  Cnn.Close
  Set rs = Nothing
  Set Cnn = Nothing
End Sub
   CopyData_5过程使建立与“数据表”工作簿的连接，查询数据记录后复制到当前工作表中。
   第8行代码删除当前工作表的所有数据。
   第9行到第15行代码建立与“数据表”工作簿的连接。
   第16行到第24行代码查询“数据表”工作簿的全部数据，并复制到工作表中。其中第20行代码将字段名称（标题行）复制到工作表中，第23行代码将查询到的数据记录复制到工作表。
★★★★★★★★★★★★★★★UTF8
Sub S1()

Filename = "C:\Users\Administrator\Desktop\VBA\TEST.txt"

Dim stream As Object
Set stream = CreateObject("ADODB.Stream")

' 设置流类型
stream.Type = 2 ' adTypeText
' 设置字符集
stream.Charset = "utf-8"
' 打开流
    stream.Open
' 加载文件
stream.LoadFromFile Filename
' 读取数据
Dim fileContent As String
fileContent = stream.ReadText
' 关闭流
stream.Close
Close #1
Open Filename For Output As #1
Print #1, fileContent
Close #1

' 关闭流
Open Filename For Input As #1
j = 1
Do While Not EOF(1)
   Line Input #1, myText
　　Sheets("test").Cells(j, 1) = myText
　　j = j + 1
Loop
Close #1

End Sub

 

1-2 使用Cells属性

使用Cells属性返回一个Range对象，如下面的代码所示。

  Sub Cell()
      Dim icell As Integer
      For icell = 1 To 100
          Sheet2.Cells(icell, 1).Value = icell
      Next
  End Sub
       Cell过程使用For...Next语句为工作表中的A1:A100单元格区域填入序号。
        Cells属性指定单元格区域中的单元格，语法如下：
Cells(RowIndex, ColumnIndex) 参数RowIndex是可选的，表示引用区域中的行序号。
        参数ColumnIndex是可选的，表示引用区域中的列序号。
        如果缺省参数，Cells属性返回引用对象的所有单元格。
        Cells属性的参数可以使用变量，因此经常应用于在单元格区域中循环。

1-3 使用快捷记号

在VBA中可以将A1引用样式或命名区域名称使用方括号括起来，作为Range属性的快捷方式，这样就不必键入单词“Range”或使用引号，如下面的代码所示。

  Sub Fastmark()
      [A1：A5] = 2
      [Fast] = 4
  End Sub
       Fastmark过程使用快捷记号为单元格区域赋值。
        第2行代码使用快捷记号将活动工作表中的A1：A5单元格赋值为2。
        第3行代码将工作簿中已命名为“Fast”的单元格区域赋值为4。

注意 使用快捷记号引用单元格区域时只能使用固定字符串而不能使用变量。

 

1-4 使用Offset属性

可以使用Range对象的Offset属性返回一个基于引用的Range对象的单元格区域，如下面的代码所示。

  Sub Offset()
      Sheet3.Range("A1:C3").Offset(3, 3).Select
  End Sub
       Offset过程使用Range对象的Offset属性选中A1：A3单元格偏移三行三列后的区域。
        应用于Range对象的Offset 属性的语法如下：
expression.Offset(RowOffset, ColumnOffset) 参数expression是必需的，该表达式返回一个Range对象。
        参数RowOffset是可选的，区域偏移的行数（正值、负值或 0（零））。
正值表示向下偏移，负值表示向上偏移，默认值为 0。
        参数ColumnOffset是可选的，区域偏移的列数（正值、负值或 0（零））。
正值表示向右偏移，负值表示向左偏移，默认值为 0。
        运行Offset过程，选中A1：A3单元格偏称三行三列后的区域，如图所示。

 

1

依然潇潇
第1部分Range（单元格）对象
技巧1 单元格的引用方法

1-5 使用Resize属性

使用Range对象的Resize属性调整指定区域的大小，并返回调整大小后的单元格区域，如下面的代码所示。

  Sub Resize()
      Sheet4.Range("A1").Resize(3, 3).Select
  End Sub
       Resize过程使用Range对象的Resize属性选中A1单元格扩展为三行三列后的区域。
        Resize属性的语法如下：
expression.Resize(RowSize, ColumnSize) 参数expression是必需的，返回要调整大小的Range 对象 参数RowSize是可选的，新区域中的行数。
如果省略该参数，则该区域中的行数保持不变。
        参数ColumnSize是可选的，新区域中的列数。
如果省略该参数。
则该区域中的列数保持不变。
        运行Resize过程，选中A1单元格扩展为三行三列后的区域，如图所示。

第1部分Range（单元格）对象
技巧1 单元格的引用方法

1-6 使用Union方法

使用Union方法可以将多个非连续区域连接起来成为一个区域，从而可以实现对多个非连续区域一起进行操作，如下面的代码所示。

  Sub UnSelect()
      Union(Sheet5.Range("A1:D4"), Sheet5.Range("E5:H8")).Select
  End Sub
       UnSelect过程选择单元格A1:D4和E5:H8所组成的区域。
Union方法返回两个或多个区域的合并区域，语法如下：
expression.Union(Arg1, Arg2, ...)
       其中参数expression是可选的，返回一个Application对象。
        参数Arg1, Arg2, ...是必需的，至少指定两个Range对象。
        运行UnSelect过程，选中单元格A1:D4和E5:H8所组成的区域，如图所示。

第1部分Range（单元格）对象
技巧1 单元格的引用方法

1-7 使用UsedRange属性

使用UsedRange属性返回指定工作表上已使用单元格组成的区域，如下面的代码所示。

  Sub UseSelect()
     Sheet6.UsedRange.Select
  End Su
       UseSelect过程使用UsedRange属性选择工作表上已使用单元格组成的区域，包括空单元格。
如工作表中已使用A1单元格和D8单元格，运行UseSelect过程将选择A1到D8单元格区域，如图所示。

点评
bluexuemei
原来还包括空单元格，学习！

6

又见随风
feiaoli
剑倚青天笛倚楼
VBA也太难了
学习邹
第1部分Range（单元格）对象
技巧1 单元格的引用方法

1-8 使用CurrentRegion属性

使用CurrentRegion属性返回指定工作表上当前的区域，如下面的代码所示。

  Sub CurrentSelect()
      Sheet7.Range("A5").CurrentRegion.Select
  End Sub
       CurrentSelect过程使用CurrentRegion属性选择工作表上A5单元格当前的区域，当前区域是一个边缘是任意空行和空列组合成的范围。
        运行CurrentSelect过程将选择A5到B6单元格区域，如图所示。

第1部分Range（单元格）对象

技巧1 单元格的引用方法附件。

第1部分Range（单元格）对象
技巧2 选定单元格区域的方法

2-1 使用Select方法

在VBA中一般使用Select方法选定单元格或单元格区域，如下面的代码所示。

  Sub RngSelect()
      Sheet3.Activate
      Sheet3.Range("A1：B10").Select
  End Sub
       RngSelect过程使用Select方法选定Sheet3中的A1：B10单元格区域，Select方法应用于Range对象时语法如下：
expression.Select(Replace)
       参数expression是必需的，一个有效的对象。
        参数Replace是可选的，要替换的对象。
        使用Select方法选定单元格时，单元格所在的工作表必需为活动工作表，所以先使用Activate方法使Sheet3成为活动工作表，否则Select方法有可能出错，显示如图所示的错误提示。

第1部分Range（单元格）对象
技巧2 选定单元格区域的方法

2-2 使用Activate方法

还可以使用Activate方法选定单元格或单元格区域，如下面的代码所示。

  Sub RngActivate()
      Sheet3.Activate
      Sheet3.Range("A1:B10").Activate
  End Sub
       RngActivate过程使用Activate方法选定Sheet3中的A1：B10单元格区域，Activate方法应用于Range对象时语法如下：
expression.Activate 使用Activate方法选定单元格时，单元格所在的工作表也必需为活动工作表，否则Activate方法有可能出错，显示如图所示的错误提示。

第1部分Range（单元格）对象
技巧2 选定单元格区域的方法

2-3 使用Goto方法

使用Goto方法无需使单元格所在的工作表成为活动工作表，如下面的代码所示。

  Sub RngGoto()
      Application.Goto Reference:=Sheet3.Range("A1：B10"), scroll:=True
  End Sub
       RngGoto过程使用Goto方法选定Sheet3中的A1：B10单元格区域，并滚动工作表以显示该单元格。
        Goto方法选定任意工作簿中的任意区域或任意Visual Basic过程，并且如果该工作簿未处于活动状态，就激活该工作簿，语法如下：
expression.Goto(Reference, Scroll)
       参数expression是必需的，返回一个Application 对象。
        参数Reference是可选的，Variant类型，指定目标。
可以是Range对象、包含R1C1-样式记号的单元格引用的字符串或包含 Visual Basic 过程名的字符串。
如果省略本参数，目标将是最近一次用Goto方法选定的区域。
 参数Scroll是可选的，Variant类型，如果该值为True，则滚动窗口直至目标区域的左上角单元格出现在窗口的左上角。
如果该值为False，则不滚动窗口。
默认值为False。

 

点评
bluexuemei
原来选择单元格区域不止select一种方法，学习了！

1

征婚启事
https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=3
第1部分Range（单元格）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧3 获得指定行、列中的最后一个非空单元格 使用VBA对工作表进行操作时，经常需要定位到指定行或列中最后一个非空单元格，此时可以使用Range对象的End属性，在取得单元格对象后便能获得该单元格的相关属性，如单元格地址、行列号、数值等，如下面的代码所示。

  Sub LastRow()
      Dim rng As Range
      Set rng = Sheet1.Range("A65536").End(xlUp)
      MsgBox "A列中最后一个非空单元格是" & rng.Address(0, 0) _
          & ",行号" & rng.Row & ",数值" & rng.Value
      Set rng = Nothing
  End Sub
       LastRow过程使用消息框显示工作表中A列最后非空单元格的地址、行号和数值。
        End属性返回一个Range对象，该对象代表包含源区域的区域尾端的单元格。
等同于按键<End+向上键>、<End+向下键>、<End+向左键>或<End+向右键>，语法如下：
expression.End(Direction) 参数expression是必需的，一个有效的对象。
        参数Direction是可选的，所要移动的方向，可以为如图所示的XlDirection 常量之一。

       Range对象的End属性返回的是一个Range对象，因此可以直接使用该对象的属性和方法。

    运行LastRow过程结果如图所示。

       通过修改相应的参数，能够获得指定行中最后一个非空单元格，如下面的代码所示。

  Sub LastColumn()
      Dim rng As Range
      Set rng = Sheet1.Range("IV1").End(xlToLeft)
      MsgBox "第一行中最后一个非空单元格是" & rng.Address(0, 0) _
          & ",列号" & rng.Column & ",数值" & rng.Value
      Set rng = Nothing
  End Sub
       LastColumn过程使用消息框显示工作表中第一行最后一个非空单元格的地址、列号和数值，如图所示。

 

感谢楼主分享，能同时更新上传word 文档吗？
在第1部分内容整理结束后我会将word 文档上传，现在还只是个目录和一部分的内容。

第1部分Range（单元格）对象
技巧4 定位单元格 在Excel中使用定位对话框可以选中工作表中特定的单元格区域，而在VBA中则使用SpecialCells方法，如下面的代码所示。

  Sub SpecialAddress()
      Dim rng As Range
      Set rng = Sheet1.UsedRange.SpecialCells(xlCellTypeFormulas)
      rng.Select
      MsgBox "工作表中有公式的单元格为： " & rng.Address
      Set rng = Nothing
  End Sub

代码解析： SpecialAddress过程使用SpecialCells方法选中工作表中有公式的单元格，并用消息框显示其地址。
        SpecialCells方法返回一个Range对象，该对象代表与指定类型及值相匹配的所有单元格，语法如下：
expression.SpecialCells(Type, Value)
       参数expression是必需的，返回一个有效的对象。
        参数Type是必需的，要包含的单元格，可为表格所列的XlCellType常量之一。

       第3行代码将SpecialCells方法的Type参数设置为xlCellTypeFormulas，返回的是含有公式的单元格，通过修改相应的参数可以返回不同的单元格。
        参数Value是可选的，如果Type参数为xlCellTypeConstants或xlCellTypeFormulas， 此参数可用于确定结果中应包含哪几类单元格。
将某几个值相加可使此方法返回多种类型的单元格。
如果省略将选定所有常量或公式，可为表格所列的 XlSpecialCellsValue常量之一。

       第5行代码使用消息框显示工作表中含有公式单元格的地址。
SpecialCells方法返回的是Range对象，因此可以直接使用该对象的属性和方法。
        运行SpecialAddress过程结果如图所示。

 

第1部分Range（单元格）对象
技巧5 查找单元格

5-1 使用Find方法

在Excel中使用查找对话框可以查找工作表中特定内容的单元格，而在VBA中则使用Find方法，如下面的代码所示。

  Sub RngFind()
      Dim StrFind As String
      Dim Rng As Range
      StrFind = InputBox("请输入要查找的值:")
      If Trim(StrFind) <> "" Then
          With Sheet1.Range("A:A")
              Set Rng = .Find(What:=StrFind, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
              If Not Rng Is Nothing Then
                  Application.Goto Rng, True
              Else
                  MsgBox "没有找到该单元格!"
              End If
          End With
      End If
  End Sub
       RngFind过程使用Find方法在工作表Sheet1的A列中查找InputBox函数对话框中所输入的值，并查找该值所在的第一个单元格。
        第6到第13行代码在工作表Sheet1的A列中查找InputBox函数对话框中所输入的值。
应用于Range对象的Find方法在区域中查找特定信息，并返回Range对象，该对象代表用于查找信息的第一个单元格。
如果未发现匹配单元格，就返回Nothing，语法如下：
expression.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SerchFormat)
       参数expression是必需的，该表达式返回一个Range对象。
        参数What是必需的，要搜索的数据，可为字符串或任意数据类型。
        参数After是可选的，表示搜索过程将从其之后开始进行的单元格，必须是区域中的单个单元格。
查找时是从该单元格之后开始的，直到本方法绕回到指定的单元格时，才对其进行搜索。
如果未指定本参数，搜索将从区域的左上角单元格之后开始。
        在本例中将After参数设置为A列的最后一个单元格，所以查找时从A1单元格开始搜索。
        参数LookIn是可选的，信息类型。
        参数LookAt是可选的，可为XlLookAt常量的xlWhole 或xlPart之一。
        参数SearchOrder是可选的，可为XlSearchOrder常量的xlByRows或xlByColumns之一。
        参数SearchDirection是可选的，搜索的方向，可为XlSearchDirection常量的xlNext或xlPrevious之一。
        参数MatchCase是可选的，若为True，则进行区分大小写的查找。
默认值为False。
        参数MatchByte是可选的，仅在选择或安装了双字节语言支持时使用。
若为True，则双字节字符仅匹配双字节字符。
若为False，则双字节字符可匹配其等价的单字节字符。
        参数SerchFormat是可选的，搜索的格式。
        每次使用Find方法后，参数LookIn、LookAt、SearchOrder 和MatchByte的设置将保存。
如果下次调用Find方法时不指定这些参数的值，就使用保存的值。
因此每次使用该方法时请明确设置这些参数。
        如果工作表的A列中存在重复的数值，那么需要使用FindNext方法或FindPrevious方法进行重复搜索，如下面的代码所示。

  Sub RngFindNext()
      Dim StrFind As String
      Dim Rng As Range
      Dim FindAddress As String
      StrFind = InputBox("请输入要查找的值:")
      If Trim(StrFind) <> "" Then
          With Sheet1.Range("A:A")
              Set Rng = .Find(What:=StrFind, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
              If Not Rng Is Nothing Then
                  FindAddress = Rng.Address
                  Do
                      Rng.Interior.ColorIndex = 6
                      Set Rng = .FindNext(Rng)
                  Loop While Not Rng Is Nothing And Rng.Address <> FindAddress
              End If
          End With
      End If
  End Sub
       RngFindNext过程在工作表Sheet1的A列中查找InputBox函数对话框中所输入的值，并将查到单元格底色设置成黄色。
        第8行到第17行代码使用Find方法在工作表Sheet1的A列中查找。
        第16行代码将查找到的第一个单元格地址赋给字符串变量FindAddress。
        第18行代码将查找到的单元格底色设置成黄色。
        第19行代码使用FindNext方法进行重复搜索。
FindNext方法继续执行用Find方法启动的搜索。
查找下一个匹配相同条件的单元格并返回代表单元格的Range对象，语法如下：
expression.FindNext(After)
       参数expression是必需的，返回一个Range对象。
        参数After是可选的，指定一个单元格，查找将从该单元格之后开始。
        第20行代码如果查找到的单元格地址等于字符串变量FindAddress所记录的地址，说明A列已搜索完毕，结束查找过程。
        运行RngFindNext过程，在InputBox函数输入框中输入“196.01”后结果如所示。

       还可以使用FindPrevious方法进行重复搜索，FindPrevious方法的语法如下：
expression.FindPrevious(After)
       FindPrevious方法和FindNext方法唯一的区别是FindPrevious方法查找匹配相同条件的前一个单元格而FindNext方法是查找匹配相同条件的下一个单元格。

第1部分Range（单元格）对象
技巧5 查找单元格

5-2 使用Like运算符

使用Like运算符可以进行更为复杂的模式匹配查找，如下面的代码所示。

  Sub RngLike()
      Dim rng As Range
      Dim a As Integer
      a = 1
      With Sheet2
          .Range("A:A").ClearContents
          For Each rng In .Range("B1:E1000")
              If rng.Text Like "*a*" Then
                  .Range("A" & a) = rng.Text
                  a = a + 1
              End If
          Next
      End With
  End Sub
       RngLike过程使用For Each...Next语句和Like运算符在单元格区域B1:E10000中搜索含有“a”字符的单元格，找到匹配单元格以后将单元格的值写入到A列中。
        第6行代码使用ClearContents方法清除A列区域的数据。
        第7行代码使用For Each...Next语句在单元格区域B1:E10000中循环。
        第8行代码使用Like运算符在单元格区域B1:E10000中搜索含有“a”字符的单元格。
        Like运算符用来比较两个字符串，语法如下：
result = string Like pattern
       参数string是必需的，字符串表达式。
        参数pattern是必需的，字符串表达式。
        如果string与pattern匹配，则result为True；如果不匹配，则result为False。
但是如果string或pattern 中有一个为Null，则result 为 Null。
        参数pattern可以使用通配符、字符串列表或字符区间的任何组合来匹配字符串。
表格中列出pattern中允许的字符以及它们与什么进行匹配。

       第9行代码将找到的匹配单元格的值写入到A列中。
        运行RngLike过程结果如图所示。

 

第1部分Range（单元格）对象
技巧6 替换单元格内字符串 如果需要替换单元格内指定的字符串，那么使用Range对象的Replace方法，如下面的代码所示。

  Sub RngReplace()
      Range("A1:A5").Replace "通州", "南通"
  End Sub
       RngReplace过程将工作表A1:A5单元格中的“通州”字符串替换成“南通”字符串。
        应用于Range对象的Replace方法替换指定区域内单元格中的字符，语法如下：
expression.Replace(What, Replacement, LookAt, SearchOrder, MatchCase, MatchByte, SearchFormat, ReplaceFormat)
       其中参数expression是必需的，返回一个Range对象。
        参数What是必需的，要搜索的字符串。
        参数Replacement是必需的，替换的字符串。
        运行RngReplace过程前工作表如图所示。

       运行RngReplace过程后结果如图所示。

 

第1部分Range（单元格）对象
技巧7 复制单元格区域 在实际操作中，经常需要复制指定的单元格区域到另外一个单元格区域。
要复制指定单元格区域到其他位置，使用Range对象的Copy方法，如下面的代码所示。

  Sub RangeCopy()
      Application.DisplayAlerts = False
      Sheet1.Range("A1").CurrentRegion.Copy Sheet2.Range("A1")
      Application.DisplayAlerts = True
  End Sub
       RangeCopy过程将如图所示的Sheet1工作表中A1单元格的当前区域复制到Sheet2工作表中以A1单元格为左上角单元格的区域。

       Sheet2工作表复制后如图所示。

       Range对象的Copy方法的语法如下：
Copy(Destination)
       参数Destination表示复制单元格区域的目标区域，如果省略该参数，Excel将把该区域复制到剪贴板中。
使用Copy方法复制单元格区域时，也复制了该单元格区域的格式。
        复制单元格区域时，如果目标区域为非空单元格区域，Excel将显示如图所示的消息框提示是否替换单元格内容，可以设置Application.DisplayAlerts属性值为False，使复制时不出现该消息框。

        第2行代码通常复制单元格区域的操作不会将单元格区域的列宽大小同时复制，如果希望在复制单元格区域的同时，也复制源区域的列宽大小，可以使用下面的代码。

  Sub CopyWithSameColumnWidths()
      Sheet1.Range("A1").CurrentRegion.Copy
      With Sheet3.Range("A1")
          .PasteSpecial xlPasteColumnWidths
          .PasteSpecial xlPasteAll
      End With
      Application.CutCopyMode = False
  End Sub
        第4行代码使用Range对象的PasteSpecial方法选择性粘贴剪贴板中的Range对象的列宽。
         第5行代码粘贴剪贴板中的Range对象全部内容。
         第7行代码取消应用程序复制模式。
         应用于Range对象的PasteSpecial方法将剪贴板中的Range对象粘贴到指定区域，在粘贴时可以有选择的粘贴对象的部分属性。
其语法如下：
PasteSpecial(Paste, Operation, SkipBlanks, Transpose)
        参数Paste指定要粘贴的区域部分，可为表格所列的XlPasteType常量之一。

        参数Operation指定粘贴操作。
可为表格所列的XlPasteSpecialOperation常量之一。

        参数SkipBlanks指示是否跳过空单元格，若参数值为True，则不将剪贴板上区域中的空白单元格粘贴到目标区域中。
默认值为False。
         参数Transpose指示是否进行转置，若参数值为True，则粘贴区域时转置行和列。
默认值为False。
         运行CopyWithSameColumnWidths过程后，Sheet3工作表如图所示，目标区域的各列列宽与源区域一致。

注意 使用PasteSpecial方法时指定xlPasteAll(粘贴全部)，不会粘贴列宽。

 

班主，最近在想办法把日常office的工作通过vba实现，发现这个论坛正是我想要的。
 想问一下斑竹：什么时候介绍一下如何使用vba实现动态修改图表(chart)中的数据源的方法？
在Shape（图形）与Chart（图表）对象这部分中有这方面的内容。

第1部分Range（单元格）对象
技巧8 仅复制数值到另一区域 如果在复制单元格区域时，仅希望复制单元格区域的数值，有下面几种方法。

8-1 使用选择性粘贴

使用选择性粘贴功能并指定粘贴数值，如下面的代码所示。

  Sub CopyPasteSpecial()
      Sheet1.Range("A1").CurrentRegion.Copy
      Sheet2.Range("A1").PasteSpecial Paste:=xlPasteValues
      Application.CutCopyMode = False
  End Sub
       CopyPasteSpecial过程复制工作表Sheet1中A1单元格的当前区域的数值到工作表Sheet2的A1单元格所在区域中。
        第2行代码将如图所示的Sheet1中A1单元格的当前区域进行复制。

       第3行代码使用选择性粘贴功能并指定粘贴数值，选择性粘贴数值仅复制了单元格区域的数值，单元格区域的格式（背景颜色、字体对齐格式和边框等）不会被复制，复制结果如图所示。

8-2 直接赋值的方法

除了使用Copy方法外，还可以使用直接赋值的方法，如下面的代码所示。

  Sub GetValueResize()
      With Sheet1.Range("A1").CurrentRegion
          Sheet3.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
      End With
  End Sub
       GetValueResize过程将工作表Sheet1中的A1单元格的当前区域的数值赋予工作表Sheet3的A1单元格所在的单元格区域。
        在对单元格区域直接赋值时，应保证源区域大小与目标区域的大小一致，如果源区域为动态的单元格区域，可使用Resize方法确定目标区域。
        运行GetValueResize过程，赋值结果如上图所示。

 

1

学习邹
第1部分Range（单元格）对象
技巧9 单元格自动进入编辑状态 当光标选择单元格时无需双击，自动进入编辑状态，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      If Target.Column = 3 And Target.Count = 1 Then
          If Target <> "" Then
              Application.SendKeys "{F2}"
          End If
      End If
  End Sub
       工作表的SelectionChange事件过程，当选择工作表C列有数据单元格时自动进入编辑状态。
        第2、3行代码设置SelectionChange事件的触发条件，利用Target参数的Column属性和Count属性将事件的触发条件限制在C列并且只有在选择一个单元格时才发生。
        第4行代码使用SendKeys方法发送一个F2键到应用程序，等同于选择单元格后按F2键，使单元格进入编辑状态。

 

2

征婚启事
0372nhyz
https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=4
第1部分Range（单元格）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧10 禁用单元格拖放功能 在工作表中可以拖放单元格右下角的小十字对单元格内容进行复制等操作，如果不希望用户进行此操作可以禁用单元格拖放功能，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      If Not Application.Intersect(Target, Range("A1:A15")) Is Nothing Then
          Application.CellDragAndDrop = False
      Else
          Application.CellDragAndDrop = True
      End If
  End Sub
       工作表的SelectionChange事件过程，在指定的单元格区域禁用单元格的拖放功能。
        CellDragAndDrop 属性设置单元格的拖放功能，如果允许使用单元格拖放功能，则该值为True。
        为了不影响其他工作表，应在工作表的Deactivate事件中恢复单元格的拖放功能，如下面的代码所示。

  Private Sub Worksheet_Deactivate()
      Application.CellDragAndDrop = True
  End Sub
       工作表的Deactivate事件过程，恢复单元格的拖放功能。
        工作表的Deactivate事件当工作表从活动状态转为非活动状态时产生，语法如下：
Private Sub object_Deactivate()
       参数object代表Worksheet对象。
        当选择工作表“Sheet1”的A1：A15单元格时将禁用单元格的拖放功能，如图所示。

 

第1部分Range（单元格）对象
技巧11 单元格格式操作

11-1 单元格字体格式设置

在VBA中可以对单元格的字体格式进行各种设置，如下面的代码所示。

  Public Sub RngFont()
      With Range("A1").Font
          .Name = "华文彩云"
          .FontStyle = "Bold"
          .Size = 18
          .ColorIndex = 3
          .Underline = 2
      End With
  End Sub
       RngFont过程对单元格A1的字体格式进行设置。
        其中第3行代码设置字体为“华文彩云”，应用于Font对象的Name属性返回或设置对象的名称。
        第4行代码设置字体为加粗，FontStyle属性返回或设置字体样式。
设置为“Bold” 加粗字体，设置为“Italic”倾斜字体，也可以设置成“Bold Italic”。
        第5行代码设置字体的大小为18磅，Size属性返回或设置字体大小。
        第6行代码设置字体的颜色为红色，应用于Font对象的ColorIndex属性返回或设置字体的颜色，该颜色可指定为当前调色板中颜色的编号，如图所示。

       第7行代码设置字体为单下划线类型，Underline属性返回或设置应用于字体的下划线类型，可为表格所列的XlUnderlineStyle常量之一。

       运行RngFont过程结果如图所示。

 

第1部分Range（单元格）对象
技巧11 单元格格式操作

11-2 设置单元格内部格式

设置单元格的Interior属性可以对单元格的内部格式进行设置，如下面的代码所示。

  Sub RngInterior()
      With Range("A1").Interior
          .ColorIndex = 3
          .Pattern = xlPatternCrissCross
          .PatternColorIndex = 6
      End With
  End Sub
       RngInterior过程对A1单元格的内部格式进行设置。
        第2行代码使用Interior属性返回单元格对象的内部。
        第3行代码设置单元格边框内部的颜色为红色。
应用于Interior对象的ColorIndex属性返回或设置边框内部的颜色，可指定为如技巧11-1所示的当前调色板中颜色的编号或为XlColorIndex 常量之一：xlColorIndexAutomatic （自动填充）、xlColorIndexNone （无内部填充）。
        第4行代码设置单元格设置内部图案为十字图案。
应用于Interior对象的Pattern属性返回或者设置内部图案。
        第5行代码设置单元格设置内部图案的颜色为黄色。
应用于Interior对象的PatternColorIndex属性返回或设置内部图案的颜色，可指定为如技巧11-1中所示的当前调色板中颜色的编号或为XlColorIndex常量之一：xlColorIndexAutomatic （自动填充）、xlColorIndexNone （无内部填充）。
 运行RngInterior过程结果如图所示。

 

第1部分Range（单元格）对象
技巧11 单元格格式操作

11-3 为单元格区域添加边框

  Sub AddBorders()
       Dim rng As Range
       Set rng = Range("B4:G10")
       With rng.Borders
           .LineStyle = xlContinuous
           .Weight = xlThin
           .ColorIndex = 5
       End With

       Set rng = Nothing
  End Sub
       AddBorders过程为单元格区域B4:G10设置内部统一边框并添加一个加粗外边框。
        第4行到第8行代码使用Borders属性引用单元格区域的Borders集合，其中第5行代码设置其边框样式线条的样式，第6行代码设置边框线条的粗细，第7行代码设置边框的颜色。
        应用于Range对象的Borders集合代表Range对象的4个边框（左边框、右边框、顶部边框和底部边框）的4个Border对象组成的集合，这4个边框既可单独返回，也可作为一个组同时返回。

       其中LineStyle参数设置边框线条的样式，Weight参数设置边框线条的粗细，ColorIndex参数设置边框颜色，Color参数以RGB值指定边框的颜色。
        注意 指定Color参数可以设置颜色为当前调色板之处的其它颜色，不能同时指定ColorIndex参数和Color参数。
        运行AddBorders过程，效果如图所示。

       如果需要在单元格区域中应用多种边框格式，则需分别设置各边框格式，如下面的代码所示。

  Sub BordersDemo()
       Dim rng As Range
       Set rng = Sheet2.Range("B4:G10")
       With rng.Borders(xlInsideHorizontal)
           .LineStyle = xlDot
           .Weight = xlThin
           .ColorIndex = 5
       End With
       With rng.Borders(xlInsideVertical)
           .LineStyle = xlContinuous
           .Weight = xlThin
           .ColorIndex = 5
       End With

       Set rng = Nothing
  End Sub
       BordersDemo过程代码为单元格区域内部边框在水平和垂直方向上应用不同格式，并为区域添加一个加粗外边框。
        Borders(index)属性返回单个Border对象，其Index参数取值可为表格所列的XlBordersIndex常量之一：
       运行BordersDemo过程效果如图所示。

 

第1部分Range（单元格）对象
技巧11 单元格格式操作

11-4 灵活设置单元格的行高列宽

一般情况下单元格的行高列宽都是以磅为单位进行设置的，也可以使用英寸和厘米计量单位设置单元格的行高列宽，如下面的代码所示。

  Sub RngToPoints()
      With Range("A1")
          .RowHeight = Application.CentimetersToPoints(2)
          .ColumnWidth = Application.CentimetersToPoints(1.5)
      End With
      With Range("A2")
          .RowHeight = Application.InchesToPoints(1.2)
          .ColumnWidth = Application.InchesToPoints(0.3)
      End With
  End Sub
       RngToPoints过程以英寸和厘米计量单位设置单元格的行高列宽。
        第3、4行代码使用CentimetersToPoints方法以厘米为计量单位设置A1单元格的行高列宽。
CentimetersToPoints方法将计量单位从厘米转换为磅（一磅等于 0.035 厘米），语法如下：
expression.CentimetersToPoints(Centimeters) 参数expression是必需的，返回一个Application对象。
        参数Centimeters是必需的，指定要转换为磅值的厘米值。
        第5、6行代码使用InchesToPoints方法以英寸为计量单位设置B2单元格的行高列宽。
InchesToPoints方法将计量单位从英寸转换为磅，语法如下：
expression.InchesToPoints(Inches) 参数expression是必需的，返回一个Application对象。
        参数Inches是必需的，指定要转换为磅值的英寸值。
        运行RngToPoints过程结果如图所示。

 

点评
cbtaja
版主，你这条的应用有误。
EXCEL中，列宽、行高的计量单位是不同的：行高的计量单位是“磅”，列宽计量单位却是“标准字符个数”。
从贴中的图就明显看出：“列宽1.5厘米”反倒比"行高2厘米”还要大许多，显然不对。
  

1

yixiao886
第1部分Range（单元格）对象
技巧12 单元格中的数据有效性

12-1 在单元格中建立数据有效性

在单元格中建立数据有效性可以使用Add方法，如下面的代码所示。

  Sub Validation()
      With Range("A1:A10").Validation
         .Delete
          .Add Type:=xlValidateList, _
              AlertStyle:=xlValidAlertStop, _
              Operator:=xlBetween, _
              Formula1:="1,2,3,4,5,6,7,8"
      End With
  End Sub
       Validation过程使用Add方法在A1：A10单元格中建立数据有效性。
        第3行代码删除已建立的数据有效性，防止代码运行出错。
        第4行到第7行代码使用Add方法建立数据有效性。
应用于Validation对象的Add方法的语法如下：
expression.Add(Type, AlertStyle, Operator, Formula1, Formula2)
       参数expression是必需的，返回一个Validation对象。
        参数Type是必需的，数据有效性类型。
        参数AlertStyl是可选的，有效性检验警告样式。
        参数Operator是可选的，数据有效性运算符。
        参数Formula1是可选的，数据有效性公式的第一部分。
        参数Formula2是可选的，当Operator为xlBetween或xlNotBetween时，数据有效性公式的第二部分（其他情况下，此参数被忽略）。
        Add 方法所要求的参数依有效性检验的类型而定，如表格所示。

12-2 判断单元格是否存在数据有效性

在VBA中没有专门的属性判断单元格是否存在数据有效性设置，可以使用Validation对象的有效性类型和错误陷阱来判断，如下面的代码所示。

  Sub Validation()
      On Error GoTo Line
      If Range("A2").Validation.Type >= 0 Then
          MsgBox "单元格有数据有效性!"
          Exit Sub
      End If
  Line:
      MsgBox "单元格没有数据有效性!"
  End Sub
       Validation过程使用Validation对象的有效性类型和错误陷阱来判断A2单元格中是否存在数据有效性。
        第6行代码，如果A2单元格中存在数据有效性，Type参数值就会大于等于0，否则就会发生错误，使用On Error GoTo捕捉到错误后转移到第8行代码，显示一个消息框。

12-3 动态的数据有效性

利用VBA可以在单元格中建立动态的数据有效性，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      If Target.Column = 1 And Target.Count = 1 And Target.Row > 1 Then
          With Target.Validation
              .Delete
              .Add Type:=xlValidateList, _
                  AlertStyle:=xlValidAlertStop, _
                  Operator:=xlBetween, _
                  Formula1:="主机,显示器"
          End With
      End If
  End Sub
  Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 Then
          With Target.Offset(0, 1).Validation
              .Delete
              Select Case Target
                  Case "主机"
                      .Add Type:=xlValidateList, _
                          AlertStyle:=xlValidAlertStop, _
                          Operator:=xlBetween, _
                          Formula1:="Z286,Z386,Z486,Z586"
                  Case "显示器"
                      .Add Type:=xlValidateList, _
                          AlertStyle:=xlValidAlertStop, _
                          Operator:=xlBetween, _
                          Formula1:="三星17,飞利浦15,三星15,飞利浦17"
              End Select
          End With
      End If
  End Sub
       第1行到第11行代码，工作表的SelectionChange事件，当选择工作表的A列单元格时，在A2以下的单元格中建立动态的数据有效性。
        其中第2行代码，利用SelectionChange事件的Target参数来限制事件的触发条件。
        第3行到第9行代码使用Add方法在A列单元格中建立数据有效性。
应用于Validation对象的Add方法请参阅技巧12-1。
        第12行到第30行代码，工作表的Change事件，当工作表A列单元格内容改变时，在B列单元格中建立动态的数据有效性。
        其中第16行到第27行代码，根据A列单元格的内容在B列对应的单元格中建立数据有效性，其Formula1参数的值根据A列单元格的内容而变化，使之达到动态数据有效性的效果，如图所示。

12-4 自动展开数据有效性下拉列表

选择工作表单元格时自动展开数据有效性的下拉列表，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      If Target.Column = 5 Then Application.SendKeys "%{down}"
  End Sub
       当选择工作表的E列中有数据有效性的单元格时使用SendKeys方法发送Alt+向下键，打开数据有效性的下拉列表。
        应用于Application对象的SendKeys方法将击键发送给活动应用程序，语法如下：
expression.SendKeys(Keys, Wait) 参数expression是可选的，该表达式返回一个Application对象。
        参数Keys是必需的，要发送的键或者组合键，以文本方式表示。
        Keys参数可以指定任何单个键或与Alt、Ctrl 或Shift的组合键（或者这些键的组合）。
每个键可用一个或多个字符表示。
例如，"a" 表示字符 a，或者 "{ENTER}" 表示 Enter。
        若要指定在按相应键时不会显示的字符（例如，Enter 或 Tab），请使用如表格所列的代码来表示相应的键，表中的每个代码表示键盘上的一个键。

当选择工作表中的E列单元格时将自动展开数据有效性的下拉列表，如图所示。

 

第1部分Range（单元格）对象
技巧13 单元格中的公式

13-1 在单元格中写入公式

使用Range对象的Formula属性可以在单元格区域中写入公式，如下面的代码所示。

  Sub rngFormula()
      Sheet1.Range("C1:C10").Formula = "=SUM(A1+B1)"
  End Sub
       应用于Range对象的Formula属性返回或设置A1样式表示的Range对象的公式，语法如下：
expression.Formula 参数expression是必需的，返回一个Range对象。
        还可以使用FormulaR1C1属性返回或设置以R1C1-样式符号表示的公式，如下面的代码所示。

  Sub rngFormulaRC()
      Sheet2.Range("C1:C10").FormulaR1C1 = "=SUM(RC[-2]+RC[-1])"
  End Sub

  Sub RngFormulaArray()
      Sheet3.Range("C1").FormulaArray = "=A1:A2*B1:B2"
  End Sub

13-2 检查单元格是否含有公式

使用单元格的HasFormula属性检查单元格是否含有公式,如下面的代码所示。

  Private Sub CommandButton1_Click()
      Select Case Selection.HasFormula
          Case True
              MsgBox "公式单元格!"
          Case False
              MsgBox "非公式单元格!"
          Case Else
          MsgBox "公式区域：" & Selection.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
      End Select
  End Sub
       工作表中按钮的单击过程，检查所选择的单元格区域是否含有公式。
        第2行代码返回所选择单元格区域的HasFormula属性值。
如果区域中所有单元格均包含公式，则该值为True；如果所有单元格均不包含公式，则该值为False。
        第3、4行代码，如果返回True，说明区域中所有单元格均包含公式。
        第5、6行代码，如果返回False，说明区域中所有单元格均不包含公式。
        第7、8行代码，如果是混合区域，则显示包含公式的单元格地址。

13-3 判断单元格公式是否存在错误

当需要获取的单元格的值由公式返回时，公式返回的结果可能是一个错误文本，包含#NULL!、#DIV/0!、#VALUE!、#REF!、#NAME?、#NUM!、#N/A等。
此时，当单元格公式返回结果为错误文本时，如果试图通过Value属性来获得公式的返回结果，将得到类型不匹配的错误信息，如图所示。

       通过Range对象的Value属性的返回结果是否为错误类型，来判断公式是否存在错误，如下面的代码所示。

  Sub FormulaIsError()
      If VBA.IsError(Range("A1").Value) = True Then
          MsgBox "A1单元格错误类型为:" & Range("A1").Text
      Else
          MsgBox "A1单元格公式结果为" & Range("A1").Value
      End If
  End Sub
       FormulaIsError过程代码判断单元格A1中公式结果是否为错误，如果为错误则显示该错误类型，否则显示公式的结果，如图所示。

       第2行代码使用IsError函数返回Boolean值，指出表达式是否为一个错误值，如果表达式表示一个错误，则IsError函数返回True，否则返回False。

13-4 取得单元格中公式的引用单元格

如果需要取得单元格中公式的引用单元格对象，可以使用Range对象的Precedents属性，如下面的代码所示。

  Sub RngPrecedent()
      Dim rng As Range
      Set rng = Sheet1.Range("C1").Precedents
      MsgBox "公式所引用的单元格有：" & rng.Address
      Set rng = Nothing
  End Sub
       在工作表的C1单元格中写有公式“SUM(“A1:B1”)”，RngPrecedent过程使用Range对象的Precedents属性取得其引用的单元格A1:B1。
        Precedents属性返回一个Range对象，该对象代表单元格的所有引用单元格。
如果有若干引用单元格，那么该区域可能是多个的选定区域（Range 对象的联合）。
        运行RngPrecedent过程结果如图所示。

13-5 将单元格中的公式转换为数值

工作表中如果存在过多的公式将影响操作速度，将单元格中的函数与公式的结果转换为数值，可以提高工作表运算效率，有下面几种方法可以实现。
        使用选择性粘贴的方法可以将函数与公式的结果转换为数值，如下面的代码所示。

  Sub SpecialPaste()
      With Range("A1:A10")
          .Copy
          .PasteSpecial Paste:=xlPasteValues
      End With
      Application.CutCopyMode = False
  End Sub
       SpecialPaste过程使用选择性粘贴方法将单元格区域的公式转换为数值。
        第3行代码将单元格区域复制到剪贴板中。
        应用于Range对象的Copy方法将单元格区域复制到指定的区域或剪贴板中，语法如下：
expression.Copy(Destination)参数expression是必需的，该表达式返回一个Range对象。
        参数Destination是可选的，指定区域要复制到的目标区域。
如果省略该参数，Microsoft Excel 将把该区域复制到剪贴板中。
        第4行代码将剪贴板中的Range对象仅复制值到单元格区域中。
        应用于Range对象的PasteSpecial方法将剪贴板中的Range对象粘贴到指定区域中，语法如下：
expression.PasteSpecial(Paste, Operation, SkipBlanks, Transpose)
       参数expression是必需的，该表达式返回一个Range对象。
        参数Paste是可选的，指定要粘贴的区域部分。
在本例中设置为xlPasteValues，仅复制值到单元格区域中。
        使用Value属性可以将函数与公式的结果转换为数值，如下面的代码所示。

  Sub UseValue()
      Range("A1:A10").Value = Range("A1:A10").Value
  End Sub
       UseValue过程使用Value属性将函数与公式的结果转换为数值。
        使用Formula属性可以将函数与公式的结果转换为数值，如下面的代码所示。

  Sub UseFormula()
      Range("A1").Formula = Range("A1").Value
  End Sub
       UseFormula过程Formula属性将函数与公式的结果转换为数值。
当Formula属性值为非公式时，返回的结果与Value属性一致。

 

3

征婚启事
飞花四月
seki_100
第1部分Range（单元格）对象
技巧14 单元格中的批注

14-1 判断单元格是否存在批注

在VBA中，可以利用Range对象的Comment属性判断单元格是否存在批注，如下面的代码所示。

  Sub HasComment()
      If Range("A1").Comment Is Nothing Then
          MsgBox "A1单元格中没有批注!"
      Else
          MsgBox "A1单元格中批注内容为：" & Chr(13) & Range("A1").Comment.Text
      End If
  End Sub
       HasComment过程判断A1单元格是否存在批注，并用消息框显示批注信息。
        Range对象的Comment属性返回一个批注对象，如果指定的单元格不存在批注，该属性返回Nothing。
        运行HasComment过程结果如图所示。

14-2 为单元格添加批注

如果希望为单元格添加批注，那么可以使用AddComment方法，如下面的代码所示。

  Sub Comment_Add()
      With Range("A1")
          If .Comment Is Nothing Then
              .AddComment Text:=.Value
              .Comment.Visible = True
          End If
      End With
  End Sub
       Comment_Add判断单元格A1中是否存在批注，如果没有批注则为单元格A1添加批注并将单元格数值作为批注文本，同时显示批注对象。
        第4行代码使用Range对象的AddComment方法为单元格添加批注。
该方法只有一个参数Text，代表批注文本。
如果单元格已经存在批注，则该方法返回一个错误。
         第5行代码显示批注对象，Visible属性确定对象是否可视。
 当单元格A1中不存在批注时，运行代码后的结果如图所示。

14-3 删除单元格中的批注

如果需要删除单元格中的批注，那么可以使用ClearComments方法、ClearNotes方法或者Delete方法，如下面的代码所示。

  Sub Commentdel()
      On Error Resume Next
      Range("A1").ClearComments
      Range("A2").ClearNotes
      Range("A3").Comment.Delete
  End Sub
       第2行代码错误处理语句，如果单元格中没有批注，那么运行第5行代码时会发生错误，所以使用On Error语句来忽略错误。
        第3行代码使用ClearComments方法删除单元格A1中的批注。
ClearComments方法清除指定区域的所有单元格批注，语法如下：
expression.ClearComments 第4行代码使用ClearNotes方法删除A2单元格中的批注。
ClearNotes方法清除指定区域中所有单元格的附注和语音批注，语法如下：
expression.ClearNotes 第5行代码使用Delete方法删除删除A3单元格中的批注.Range对象的Comment属性返回一个Comment对象，该对象代表与该区域左上角单元格相关联的批注。

 

第1部分Range（单元格）对象
技巧15 合并单元格操作

15-1 判断单元格区域是否存在合并单元格

Range对象的MergeCells属性可以确定单元格区域是否包含合并单元格，如果该属性返回值为True，则表示区域包含合并单元格。
        下面的代码判断单元格 A1是否包含合并单元格，并显示相应的提示信息。

  Sub IsMergeCell()
      If Range("A1").MergeCells = True Then
          MsgBox "包含合并单元格"
      Else
          MsgBox "没有包含合并单元格"
      End If
  End Sub 如果在指定区域中

       判断这样一个单元格区域中是否包含合并单元格，可以使用下面的代码快速判断单元格区域中是否包含部分合并单元格，而不需要遍历单元格。

  Sub IsMerge()
      If IsNull(Range("E8:I17").MergeCells) Then
          MsgBox "包含合并单元格"
      Else
          MsgBox "没有包含合并单元格"
      End If
  End Sub
       当单元格区域中同时包含合并单元格和非合并单元格时，MergeCells属性将返回Null，因此第2行代码通过该返回结果作为判断条件。
        运行IsMerge过程结果如图所示。

 

第1部分Range（单元格）对象
技巧15 合并单元格操作

15-2 合并单元格时连接每个单元格的文本

使用Excel的“合并及居中”按钮合并多个单元格区域时，Excel仅保留区域左上角单元格的内容，如果用户希望在合并如图所示单元格区域时，将各个单元格的内容连接起来保存在合并后的单元格区域中，则可以使用下面的代码。

  Sub Mergerng()
      Dim StrMerge As String
      Dim rng As Range
      If TypeName(Selection) = "Range" Then
          For Each rng In Selection
              StrMerge = StrMerge & rng.Value
          Next
          Application.DisplayAlerts = False
          Selection.Merge
          Selection.Value = StrMerge
          Application.DisplayAlerts = True
      End If
  End Sub
       Mergerng过程将所选各个单元格的内容连接起来保存在合并后的单元格区域中。
        第4行代码使用TypeName函数判断当前选定对象是否为Range对象，若是则继续执行代码。
        第5行到第7行代码将当前选中区域的内容连接起来保存在字符串变量StrMerge中。
        第8行代码将DisplayAlerts属性设置为False，禁止在合并多重数值区域时，Excel显示的警告信息，避免中断代码的运行。
        第9行代码使用Merge方法合并当前选定区域。
应用于Range对象的Merge方法通过指定Range对象创建合并单元格，语法如下：
expression.Merge(Across)
       参数expression是必需的，返回一个Range对象。
        参数Across是可选的，如果该值为True，则将指定区域内的每一行合并为一个合并单元格。
默认值为False。
        第9行也可以使用下面的代码：
Selection.MergeCells = True
       第10行代码将变量StrMerge的值赋给合并后的单元格。
        运行Mergerng过程结果如图所示。

 

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=5
第1部分Range（单元格）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧15 合并单元格操作

15-3 合并内容相同的连续单元格

如果需要合并如图所示的工作表中B列中部门相同的连续单元格，可以使用下面的代码。

  Sub Mergerng()
      Dim IntRow As Integer
      Dim i As Integer
      Application.DisplayAlerts = False
      With Sheet1
          IntRow = .Range("A65536").End(xlUp).Row
          For i = IntRow To 2 Step -1
              If .Cells(i, 2).Value = .Cells(i - 1, 2).Value Then
                  .Range(.Cells(i - 1, 2), .Cells(i, 2)).Merge
              End If
          Next
      End With
      Application.DisplayAlerts = True
  End Sub
       第7行到第11行代码，从最后一行开始，向上逐个单元格判断连续两个单元格的内容是否相同，如果相同则合并。
        运行Mergerng过程后，结果如图所示。

 

2

1055751654
征婚启事
第1部分Range（单元格）对象
技巧15 合并单元格操作

15-4 取消合并单元格时在每个单元格中保留内容

如果需要取消技巧15-3中工作表B列“部门”的合并单元格，并且各个单元格均保留原合并单元格的内容，可以使用下面的代码。

  Sub UnMerge()
      Dim StrMer As String
      Dim IntCot As Integer
      Dim i As Integer
      With Sheet1
          For i = 2 To .Range("B65536").End(xlUp).Row
              StrMer = .Cells(i, 2).Value
              IntCot = .Cells(i, 2).MergeArea.Count
              .Cells(i, 2).UnMerge
              .Range(.Cells(i, 2), .Cells(i + IntCot - 1, 2)).Value = StrMer
              i = i + IntCot - 1
          Next
      End With
  End Sub
       UnMerge过程取消工作表中B列中的合并单元格，并且各个单元格均保留原合并单元格的内容。
        第7行代码取得B列每个合并单元格的内容。
        第8行代码取得合并区域的单元格数量。
        第9行代码使用UnMerge方法取消合并单元格。
UnMerge方法将合并区域分解为独立的单元格，语法如下：
expression.UnMerge
       第10行代码将原合并单元格的内容赋值给取消合并单元格后的区域。
        第11行代码调整循环变量i的值，使下一次循环从下一个单元格区域开始。
        运行UnMerge过程结果如图所示。

 

第1部分Range（单元格）对象
技巧16 高亮显示单元格区域 如果希望以某种方式突出显示活动单元格或者指定的单元格区域，从而一目了然地获得某些信息，那么可以高亮显示活动单元格区域，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Cells.Interior.ColorIndex = xlColorIndexNone
      Target.Interior.ColorIndex = 8
  End Sub
       设置工作表当前选定区域单元格的内部填充颜色，以高亮显示选定区域，如图所示。

       第2行代码将工作表中所有的单元格的内部填充颜色设置为xlColorIndexNone，即取消单元格的内部填充颜色。
        第3行代码将工作表中选定单元格的内部填充颜色设置为8。
        应用于Interior对象的ColorIndex属性返回或设置边框内部的颜色。
该颜色可指定为当前调色板中颜色的编号（请参阅技巧11-1）或为 XlColorIndex 常量之一：xlColorIndexAutomatic（指定对图形对象自动填充）、xlColorIndexNone（用于指定无内部填充）。
        还可以高亮显示指定区域内的行列，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Dim rng As Range
      Cells.Interior.ColorIndex = xlNone
      Set rng = Application.Union(Target.EntireColumn, Target.EntireRow)
      rng.Interior.ColorIndex = 24
  End Sub

代码解析： 设置工作表当前选定区域单元格内部填充颜色，高亮显示活动单元格所在的行列，如图所示。

       第4行代码使用Union方法将所选单元格所在的行、列连接起来成为一个区域，关于Union方法请参阅技巧1-6。

注意 使用此方法时，工作表中所有设置的单元格内部填充颜色将会被清除。
（不包括通过条件格式设置的单元格内部填充颜色），同时无法在工作表中实现复制粘贴功能。

 

第1部分Range（单元格）对象
技巧17 双击被保护单元格时不显示提示消息框 当用户使用鼠标左键双击被保护工作表中锁定的单元格区域时，系统将显示如图所示的消息框。

       如果不希望显示该消息框，可以在工作表Worksheet_BeforeDoubleClick事件中进行设置，如下面的代码所示。

  Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
      If Target.Locked = True Then
          MsgBox "此单元格已保护，不能编辑!"
          Cancel = True
      End If
  End Sub
       当用户使用鼠标左键双击工作表单元格时，触发Worksheet_BeforeDoubleClick事件。
该事件中的Target参数代表用户双击鼠标左键的单元格区域。
        参数Cancel设置是否取消该操作。
如果将参数Cancel设置为True，将不进行默认的双击操作。
        第2行代码中判断用户双击鼠标左键的单元格区域是否已锁定（Range对象的Locked属性返回或设置Range对象是否锁定），如果单元格区域已锁定，则设置参数Cancel设置为True，不进行默认的双击操作，因而不再显示上图所示的提示的消息框，只显示一个自定义的提示信息，如图所示。

 

第1部分Range（单元格）对象
技巧18 重新计算工作表指定区域 如果在工作表中含有大量公式，那么在对工作表执行重新计算操作时，可能需要较长的时间。
在实际工作中，有时希望仅对指定的区域进行重新计算，以提高计算效率，那么可以使用下面的代码。

  Sub CalculationSpecialRange()
      Dim OldCalculation As XlCalculation
      OldCalculation = Application.Calculation
      Application.Calculation = xlCalculationManual
      ActiveSheet.Range("A1:D10").Calculate
      Application.Calculation = OldCalculation
  End Sub
       CalculationSpecialRange过程对单元格A1到B10区域进行重新计算。
        第3行代码保存当前应用程序的Calculation属性设置。
应用于Application对象的Calculation属性返回或设置当前应用程序的计算模式，可为表格所示的XlCalculation常量之一。

       第4行代码将计算模式设置为手动重算。
        第5行代码重新计算活动工作表指定的单元格区域B3:D7。
（指定区域之外的公式将不重新计算，但包含易失性函数的公式除外） 第6行代码恢复当前应用程序的Calculation属性设置。

 

第1部分Range（单元格）对象
技巧19 单元格录入数据后自动保护 下面的代码可以使用户在单元格录入数据后自动对已录入数据单元格进行保护,防止修改数据
  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      On Error Resume Next
      Sheet1.Unprotect Password:="12345"
      If Target.Value <> "" Then
          Target.Locked = True
          Sheet1.Protect Password:="12345"
      End If
  End Sub
       工作表的SelectionChange事件，在单元格录入数据后自动对已录入数据单元格进行保护。
        第3行代码使用Unprotect方法取消工作表的保护。
应用于Worksheet 对象的Unprotect方法取消工作表的保护，如果工作表不是受保护的，则此方法不起作用，语法如下：
expression.Unprotect(Password)
       参数expression是必需的，该表达式返回一个Worksheet 对象。
        参数Password是可选的，指定用于解除工作表的保护的密码，此密码是区分大小写的。
        第4、5行代码单元格录入数据后将Locked属性设置为True。
Locked属性应用于Range对象时，如果Range对象被锁定，则该值为True，当工作表有保护时Range对象不可被修改。
        第6行代码使用Protect方法保护工作表。
应用于Worksheet对象的Protect方法保护工作表使其不至被修改，语法如下：
expression.Protect(Password, DrawingObjects, Contents, Scenarios, UserInterfaceOnly, AllowFormattingCells, AllowFormattingColumns, AllowFormattingRows, AllowInsertingColumns, AllowInsertingRows, AllowInsertingHyperlinks, AllowDeletingColumns, AllowDeletingRows, AllowSorting, AllowFiltering, AllowUsingPivotTables)
       其中参数expression是必需的，该表达式返回一个Worksheet对象。
        参数Password是可选的，为一个字符串，该字符串为工作表指定区分大小写的密码。
        其他参数都是可选参数，其功能等同于如图所示的工作表保护对话框中的各项选项，具体请参阅VBA帮助。

 

第1部分Range（单元格）对象
技巧20 工作表事件Target参数的使用方法 在工作表的SelectionChange事件中，参数Target代表新选定的区域，在工作表的Change事件中参数Target代表更改的区域。
在实际应用中可以使用Target参数将触发工作表事件的区域限制在一定的范围内，有以下几种方法：

20-1 使用Address

属性 使用Address属性可以将触发条件限制在某一个单元格中，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      If Target.Address(0, 0) = "A1" Then
          MsgBox "你选择了A1单元格"
      End If
  End Sub
       当选择工作表A1单元格时显示一个消息框。
        第2行代码使用Address属性返回所选单元格的区域引用，当返回的区域引用是“A1”时触发SelectionChange事件，显示一个消息框。
        此方法只适用于单个单元格或者加上OR运算符可以适用于几个单元格，多则不方便。

20-2 使用Column属性和Row属性

使用单元格的Column属性和Row属性可以将触发条件限制在某一区域内，如下面的代码所示。

  Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Column = 1 And Target.Row < 11 Then
          Target.Offset(, 1) = Val(Target) * 3
      End If
  End Sub
       当改变工作表的A1到A10单元格时，如果输入的是数值则将在对应的B列单元格写入乘以3的数值。
        第2行代码使用Column属性将触发条件限制在第1列，使用Row属性将触发条件限制在第10行以内，也就是A1到A10的区域范围内。

20-3 使用Intersect方法

使用Intersect方法可以很方便的指定一个或多个区域范围，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      If Not Application.Intersect(Target, Union(Range("A1:A10"), Range("C1:C10"))) Is Nothing Then
          MsgBox "你选择了" & Target.Address(0, 0) & "单元格"
      End If
  End Sub
       当选择工作表A1到A10，C1到C10单元格时将所选的单元格地址显示在消息框中。
        第2行代码使用Intersect方法判断所选单元格是否与A1到A10，C1到C10单元格重叠，如果重叠说明所选单元格在A1到A10，C1到C10单元格区域内。
Intersect方法返回一个Range对象，此对象代表两个或多个范围重叠的矩形区域，语法如下：
expression.Intersect(Arg1, Arg2, ...)
       参数expression是可选的，返回一个Application对象。
        参数Arg1, Arg2, ...是必需的，重叠的区域。
必须指定至少两个 Range对象。

 

第1部分Range（单元格）对象
第1部分Range（单元格）对象已经完成，附件是这部分的Word文档和附件，第2部分是Worksheet（工作表）对象。

 

点评
bluexuemei
版主真是太伟大了!

1

征婚启事
我真是太高兴了,想学习VBA又感觉一时无处入手,现在好了,跟着yuan版主的节奏慢慢学,很有系统性
说实话，此贴并不是VBA入门的教程，我也写不出来，论坛中许多版主、高手的贴子都比我写得好。
但这些技巧确实都是些最基本的代码，并且围绕这些技巧详细解析了一两个知识点。
日积月累，熟练掌握这些技巧并能举一反三、灵活运用时，使用VBA解决一些问题是很简单的，并没有想象中的那么复杂。
在此贴的最后我会讲解几个VBA应用的综合实例，你会发现看似复杂的VBA程序无非就是这些基本技巧的变化、组合。

5

小姜姜123
afear
dufu021
zdmcys
1035478498
yuan版您好,我在学习的过程中发现----[技巧6 替换单元格内字符串] 这个附件中的示例没有实现替换后的效果,也没有出现替换过程的那一瞬间, 请您确认.盼复
不错，原来的附件只能替换一次，第2次就看不出效果了，我把附件修改了下，可以互相替换。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=6
第2部分Worksheet（工作表）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧21 引用工作表的方式 VBA中，在不同的工作表之间转换或者对不同工作表中的单元格区域进行操作时，需要指定引用的工作表，通常有下面几种方法：

21-1 使用工作表的名称

工作表名称是指显示在工作表标签中的文本，工作表名称可以使用WorkSheets集合和Sheets集合两种引用方式，如下面的代码所示。

  Sub ShActivate()
      Worksheets("索引号").Activate
      'Sheets("索引号").Activate
  End Sub
       WorkSheets集合包含所有的工作表，而Sheets集合不仅包含工作表集合WorkSheets，还包含图表集合Charts、宏表集合Excel4MacroSheets与MS Excel 5.0对话框集合DialogSheets等。
        任何时刻工作簿中只有一个工作表是活动工作表。

21-2 使用工作表的索引号

工作表索引号是指工作表在工作簿中的位置，Excel根据工作表在工作表标签中的位置以1开始从左向右进行编号。
下面的代码选中并激活当前工作簿中第1个工作表：
  Sub ShIndex()
      Worksheets(1).Select
  End Sub

注意 当工作簿包括工作表、宏表、图表等时，使用索引号引用工作表如Sheets(1)与WorkSheets(1)引用的可能不是同一个表。

21-3 使用工作表的代码名称

使用Worksheet对象的CodeName属性可以返回工作表的代码名称，如下面的代码所示。

  Sub ShCodeName()
      MsgBox Sheets(1).CodeName
  End Sub

21-4 使用ActiveSheet属性引用活动工作表

使用ActiveSheet属性可以返回活动工作表，如下面的代码所示。

  Sub ShActive()
      MsgBox ActiveSheet.Name
  End Sub

 

1

学习邹
第2部分Worksheet（工作表）对象
技巧22 选择工作表的方法 在VBA中需要激活或者选择某个工作表时使用Select方法或Activate方法，如下面的代码所示。

  Sub SelectSh()
      Worksheets("Sheet2").Select
  End Sub
  Sub ActivateSh()
      Worksheets("Sheet2").Activate
  End Sub
       SelectSh过程使用Select方法选择“Sheet2”工作表，而ActivateSh过程则使用Activate方法选择“Sheet2”工作表，从表面看两者的作用是相同的，但是如果“Sheet2”工作表是隐藏的，Activate方法可以正常运行，而Select方法将会出现错误，如图所示。

       如果需要同时选中工作簿中的所有工作表，则只能使用Select方法而不能使用Activate方法，如下面的代码所示。

  Sub SelectShs()
      Dim Shs As Worksheet
      For Each Shs In Worksheets
          Shs.Select False
      Next
  End Sub
  Sub SelectSheets()
      Worksheets.Select
  End Sub
  Sub ArraySheets()
      Worksheets(Array(1, 2, 3)).Select
  End Sub
    SelectShs过程遍历工作表并使用带参数的Select方法选中所有工作表。
应用于Worksheet对象的Select方法的语法如下：
Select(Replace)
       参数Replace是可选的。
如果该值为True，则用指定对象替代当前选定对象。
如果该值为False，则延伸当前选定对象以包括任何以前选定的对象。
        SelectSheets过程使用Worksheets集合的Select方法选中集合中所有的对象。
        ArraySheets过程使用Array 函数返回工作簿中的前三张工作表并使用Worksheets集合的Select方法选中前三张工作表。

 

第2部分Worksheet（工作表）对象
技巧23 遍历工作表的方法 在Excel应用中经常需要遍历工作簿中所有的工作表，有以下两种方法可以实现。

23-1 使用For

...Next 语句 使用For...Next 语句遍历工作簿中所有的工作表，如下面的代码所示。

  Sub ShCount1()
      Dim c As Integer
      Dim i As Integer
      Dim s As String
      c = Worksheets.Count
      For i = 1 To c
          s = s & Worksheets(i).Name & Chr(13)
      Next
      MsgBox "工作簿中含有以下工作表:" & Chr(13) & s
  End Sub
       ShCount1过程使用For...Next 语句遍历工作簿中所有的工作表，并用消息框显示所有的工作表名称。
        第5行代码根据Worksheet对象的Count属性返回工作簿中工作表的数量赋给变量c。
应用于Worksheet对象的Count属性返回Worksheets集合中工作表的数量，语法如下：
expression.Count
       第6行代码开始For...Next 语句循环。
For...Next 语句以指定次数来重复执行一组语句，语法如下：
For counter = start To end [Step step] [statements] [Exit For] [statements] Next [counter]
       参数counter是必需的，用做循环计数器的数值变量。
        参数start是必需的，循环计数器的初值。
        参数end是必需的，循环计数器的终值。
        参数step是可选的，环计数器的步长，缺省值为 1。
        参数statements是可选的，放在For和Next之间的一条或多条语句，它们将被执行指定的次数。
        第7行代码在For...Next循环中根据工作表的索引号取得所有工作表的名称赋给字符串变量s。

 

2

hcy1185
5252
谢谢袁版，呵呵，同时提个小建议：就是想请袁版先在一楼建个楼梯，以便于大家阅读。

二楼开始已经建好了。

第2部分Worksheet（工作表）对象
技巧23 遍历工作表的方法

23-2 使用

For Each...Next 语句 使用For Each...Next语句遍历工作簿中所有的工作表，如下面的代码所示。

  Sub ShCount2()
      Dim Sh As Worksheet
      Dim s As String
      For Each Sh In Worksheets
          s = s & Sh.Name & Chr(13)
      Next
      MsgBox "工作簿中含有以下工作表:" & Chr(13) & s
  End Sub
       ShCount2过程使用For Each...Next语句遍历工作簿中所有的工作表，并用消息框显示所有工作表名称。
        第4行代码使用For Each...Next语句遍历Worksheets集合中所有元素。
For Each...Next语句针对一个数组或集合中的每个元素，重复执行一组语句，语法如下：
For Each element In Group [statements] [Exit For] [statements] Next [element]
       参数element是必需的，用来遍历集合或数组中所有元素的变量。
        参数group是必需的，对象集合或数组的名称。
        参数statements是可选的，针对对象集合或数组中的每一项执行的一条或多条语句。
        第5行代码将返回的工作表的名称赋给字符串变量s。
        运行ShCount2过程结果如图所示。

附件在113楼。

 

1

征婚启事
第2部分Worksheet（工作表）对象
技巧24 在工作表中上下翻页 如果需要在工作簿的工作表中进行上下翻页，可以使用下面的代码。

  Sub DownSheet()
      Dim i As Integer
      i = Worksheets.Count
      If ActiveSheet.Index < i Then
          Worksheets(ActiveSheet.Index + 1).Activate
      Else
          Worksheets(1).Activate
      End If
  End Sub
  Sub UpSheet()
      Dim i As Integer
      i = Worksheets.Count
      If ActiveSheet.Index > 1 Then
          Worksheets(ActiveSheet.Index - 1).Activate
      Else
          Worksheets(i).Activate
      End If
  End Sub
       DownSheet过程向下翻页，第3、12行代码使用Worksheets对象的Count属性取得工作表的数目，第4行到第7行代码根据Index属性判断活动工作表是否是工作簿中的最后一张工作表。
如果活动工作表不是最后一张工作表则激活活动工作表的下一张工作表，否则激活第一张工作表。
        UpSheet过程向上翻页，第13行到第16行代码根据Index属性判断活动工作表是否是工作簿中的第一张工作表。
如果活动工作表不是第一张工作表则激活活动工作表的上一张工作表，否则激活最后一张工作表。

 

请问楼主一个问题，如果源区域、目标区域为动态的单元格区域，使用Resize方法确定源区域和目标区域。
 请举一个实例。

请参阅技巧技巧8仅复制数值到另一区域中的8-2直接赋值的方法，41楼。

第2部分Worksheet（工作表）对象
技巧25 工作表的添加与删除
       在工作簿中添加工作表使用Add方法，如下面的代码所示。

  Sub Addsh()
      Dim Sh As Worksheet
      With Worksheets
          Set Sh = .Add(after:=Worksheets(.Count))
          Sh.Name = "数据"
      End With
  End Sub
       Addsh过程使用Add方法在工作簿中新建“数据”工作表。
        第2行代码声明变量Sh为工作表对象。
        第4行行代码使用Add方法在工作簿的最后新建“数据”工作表。
        Add 方法应用于Sheets和Worksheets对象时新建工作表、图表或宏表，语法如下：
expression.Add(Before, After, Count, Type)
       参数Before是可选的，指定工作表对象，新建的工作表将置于此工作表之前。
        参数After是可选的，指定工作表对象，新建的工作表将置于此工作表之后。
        如果Before和 After两者均省略，则新建的工作表将插入到活动工作表之前。
        参数Count可选，要新建的工作表的数目。
默认值为 1。
        参数Type可选，指定新建的工作表类型。
        第5行代码将添加的工作表重命名为“数据”。
        如果需要在工作簿中批量添加工作表，可以使用下面的代码。

  Sub Addsh_2()
      Dim i As Integer
      Dim sh As Worksheet
      For i = 1 To 10
          Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
          sh.Name = i
      Next
  End Sub
       Addsh_2过程使用For...Next 语句和Add方法在工作簿中添加10张工作表并将添加的工作表依次重命名。
        在使用以上代码往工作簿中添加工作表时，如果工作簿中已存在相同名称的工作表，运行时会发生错误，代码中断，如图所示。

       为了避免此错误的发生，可以在添加前先删除所有的工作表，如下面的代码所示。

  Sub Delsh()
      Dim sh As Worksheet
      For Each sh In ThisWorkbook.Sheets
          If sh.Name <> "工作表的添加与删除" Then
              Application.DisplayAlerts = False
              sh.Delete
              Application.DisplayAlerts = True
          End If
      Next
  End Sub
        Delsh过程使用Delete方法删除工作簿中除了“工作表的添加与删除”工作表以外所有的工作表。
        第3行代码使用For Each...Next语句遍历代码所在工作簿中所有的工作表。
        第4行到第7行代码判断工作表名称是否为“工作表的添加与删除”,如果不是则使用Delete方法删除。
其中第5行代码将Application对象的DisplayAlerts属性设置为False，使删除时不显示如图所示系统警告对话框。

       第6行代码使用Delete方法删除工作表，应用于工作表对象的Delete方法删除指定的对象，语法如下：
expression.Delete 参数expression是必需的，该表达式返回“应用于”列表中的对象之一。
        在运行添加工作表代码前先删除工作簿中的工作表虽然可以避免同名错误,但也可能误删除有用的工作表,因此更为严谨的方法是在添加前先判断工作簿中是否存在相同名称的工作表,然后再进行下一步的操作。
        对于单张工作表可以使用下面的代码。

  Sub Addsh_3()
      Dim Sh As Worksheet
      For Each Sh In Worksheets
          If Sh.Name = "数据" Then
              MsgBox "工作簿中已有""数据""工作表,不能重复添加!"
              Exit Sub
          End If
      Next
      With Worksheets
          Set Sh = .Add(after:=Worksheets(.Count))
          Sh.Name = "数据"
      End With
  End Sub
       Addsh_3过程在使用Add方法在工作簿中新建“数据”工作表时首先判断工作簿中是否存在“数据”工作表，如果已存在“数据”工作表则不运行添加工作表的代码而只显示一个消息框进行提示，如图所示。

       还可以使用错误处理语句来绕过错误，如下面的代码所示。

  Sub Addsh_4()
      Dim sh As Worksheet
      On Error GoTo line
      With Worksheets
          Set sh = .Add(after:=Worksheets(.Count))
          sh.Name = "数据"
      End With
      Exit Sub
  line:
      MsgBox "工作簿中已有""数据""工作表,不能重复添加!"
      Application.DisplayAlerts = False
      Worksheets(Worksheets.Count).Delete
      Application.DisplayAlerts = True
  End Sub
       Addsh_4过程是先使用Add方法在工作簿中新建“数据”工作表，如果工作簿中已存在同名的工作表则使用GoTo语句转移到指定的line行处进行提示并删除已添加还没有重命名的工作表，也就是工作簿中最后一张工作表。
        如果是批量添加工作表，使用上述方法时，添加工作表和已有工作表重名时，后面即使没有重名的工作表也不能添加，所以应先使用错误处理语句忽略错误，待全部添加好以后再删除多余的工作表，如下面的代码所示。

  Sub Addsh_5()
      Dim i As Integer, arr
      Dim sh As Worksheet
      On Error Resume Next
      arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
      For i = 0 To UBound(arr)
          With Worksheets
              Set sh = .Add(after:=Sheets(.Count))
              sh.Name = arr(i)
          End With
      Next
      Application.DisplayAlerts = False
      For Each sh In Worksheets
          If sh.Name Like "Sheet*" Then sh.Delete
      Next
      Application.DisplayAlerts = True
  End Sub
       Addsh_5过程使用Add方法在工作簿中添加10张工作表并重新命名为1到10，如果工作簿中已有相同名称的工作表则不添加。
        第4行代码错误处理语句，当发生重名错误时忽略错误，继续添加工作表。
        第5行到第11行代码在工作簿中添加10张工作表并重新命名为1到10，如果工作簿中已有相同名称的工作表则忽略重命名时发生的错误，此时工作簿中添加的工作表会以系统赋与的名称命名，如“Sheet1”。
        第12行到第15行代码使用For Each...Next语句遍历工作簿中所有的工作表，将工作簿中凡是以“Sheet”开头的工作表删除。

 

第2部分Worksheet（工作表）对象
技巧26 禁止删除指定工作表 在工作表事件中是没有工作表删除事件的，为了防止用户误删除重要的工作表，除了使用保护工作簿方法外，还可以使用下面的代码。

  Public Ctl As CommandBarControl
  Sub DelSht()
      Set Ctl = Application.CommandBars.FindControl(ID:=847)
      Ctl.OnAction = "MyDelSht"
  End Sub
  Sub ResSht()
      Set Ctl = Application.CommandBars.FindControl(ID:=847)
      Ctl.OnAction = ""
  End Sub
  Sub MyDelSht()
      If VBA.UCase$(ActiveSheet.CodeName) = "SHEET2" Then
          MsgBox "禁止删除" & ActiveSheet.Name & "工作表!"
      Else
          ActiveSheet.Delete
      End If
  End Sub
       DelSht过程将工作表标签右键菜单中的“删除工作表”菜单的OnAction属性设置为“MyDelSht”。
        第3行代码使用Set语句将工作表标签右键菜单中的“删除工作表”菜单赋给变量Ctl，并将其OnAction属性设置为MyDelSht过程，该菜单被单击时将运行“MyDelSht”过程而不是系统默认的设置。
OnAction属性返回或设置一个VBA的过程名，该过程在用户单击或更改某命令栏控件的值时运行。
        ResSht过程将工作表标签右键菜单中的“删除工作表”菜单的OnAction属性恢复为默认设置。
        MyDelSht过程判断所要删除的工作表的代码名称是否是“SHEET2”，如果是则禁止删除该表而只显示一个提示消息框。
        为了不影响其他工作簿的使用，在VBE中双击ThisWorkbook写入下面的代码。

  Private Sub Workbook_Activate()
      Call DelSht
  End Sub
  Private Sub Workbook_Deactivate()
      Call ResSht
  End Sub
        工作簿的Activate事件和Deactivate事件代码，在工作簿激活时运行DelSht过程，在关闭或打开其他工作簿时运行ResSht过程，这样只禁止删除本工作簿中“SHEET2”工作表，并不影响其他工作簿。
        当删除本工作簿中的“SHEET2”工作表时，并不会执行删除工作表操作而只会显示如图所示的禁止删除工作表的消息框。

 

第2部分Worksheet（工作表）对象
技巧27 自动建立工作表目录 如果在工作簿中有许多工作表，使用时往往会建立一张目录表并插入超链接以方便选择工作表。
但是如果工作簿中的工作表经常添加和删除，使用手工建立目录很不方便，此时可以使用工作表的Activate事件自动建立工作表的目录，如下面的代码所示。

  Private Sub Worksheet_Activate()
      Dim sh As Worksheet
      Dim a As Integer
      Dim R As Integer
      R = Sheet1.[A65536].End(xlUp).Row
      a = 2
      If Sheet1.Cells(2, 1) <> "" Then
          Sheet1.Range("A2:A" & R).ClearContents
      End If
      For Each sh In Worksheets
          If sh.CodeName <> "Sheet1" Then
              Sheet1.Cells(a, 1).Value = sh.Name
              a = a + 1
          End If
      Next
  End Sub
       工作表的Activate事件，在“目录”工作表激活时自动建立工作簿中除“目录”工作表外所有工作表的目录。
        第2、3、4行代码声明变量类型。
        第5行代码取得A列最后非空单元格的行号。
        第6行代码设置变量a的初始值为2，从A2单元格开始建立工作表目录。
        第7行到第9行代码判断是否存在工作表目录，如果存在先清空原来的目录，以便更新目录。
        第10行到第15代码遍历工作簿的所有工作表，将除“目录”工作表外所有工作表的名称写入到A列单元格中。
        为了建立到各工作表的链接，使用工作表的SelectionChange事件，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Dim R As Integer
      R = Sheet1.[A65500].End(xlUp).Row
      On Error Resume Next
      If Target.Count = 1 Then
          If Target.Column = 1 Then
              If Target.Row > 1 And Target.Row <= R Then
                  Sheets(Target.Value).Select
              End If
          End If
      End If
  End Sub
       工作表的SelectionChange事件，当选择A列工作表目录中工作表名称时自动选择该单元格所对应的工作表。
        第5、6、7行代码限制该事件触发的条件。
        第8行代码选择单元格所对应的工作表。
       “目录”工作表激活后自动在A列建立工作簿中除“目录”工作表以外所有表的目录，如图所示。

 

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=7
第2部分Worksheet（工作表）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧28 工作表的深度隐藏 在使用VBA开发的工作簿文件完成交与用户使用后，我们往往希望用户在打开工作簿时启用宏，此时除了使用“禁用宏则关闭工作簿”的功能外，还可以隐藏所有有数据的工作表，如果用户在打开工作簿时禁用宏则只显示一张空白的工作表，达到强制启用宏的效果，代码如下：
  Dim sh As Worksheet
  Private Sub Workbook_BeforeClose(Cancel As Boolean)
      Sheet1.Visible = True
      For Each sh In ThisWorkbook.Sheets
          If sh.Name <> "空白" Then
              sh.Visible = xlSheetVeryHidden
          End If
      Next
      ActiveWorkbook.Save
  End Sub
  Private Sub Workbook_Open()
      For Each sh In ThisWorkbook.Sheets
          If sh.Name <> "空白" Then
              sh.Visible = xlSheetVisible
          End If
      Next
      Sheet1.Visible = xlSheetVeryHidden
  End Sub
       第2行到第10行代码是工作簿的BeforeClose事件过程，在工作簿关闭前隐藏除“空白”表以外的所有的工作表。
        第3行代码将“空白”表的Visible属性设置为True，使其可见。
        应用于Charts和Worksheets对象的Visible属性决定对象是否可见，语法如下：
expression.Visible 参数expression是必需的，该表达式返回上面的对象之一。
        Visible属性可以设置为表格所示的XlSheetVisibility常量之一。

       第4行到第8行代码使用For Each...Next语句遍历工作簿中所有的工作表，将除“空白”表以外的所有工作表的Visible属性设置为xlSheetVeryHidden，使之隐藏。
        Visible属性设置为xlSheetVeryHidden后工作表不能通过“格式”→“工作表”→“取消隐藏”菜单来显示隐藏的工作表。
        第9行代码使用Save方法保存代码所在工作簿的更改，在关闭工作簿时不显示如图所示的消息框。

       第10行到第18行代码是工作簿的Open事件过程，在打开工作簿时将除“空白”表以外的所有工作表的Visible属性设置为xlSheetVisible，取消隐藏。
如果打开工作簿时禁用宏，则工作簿中除了“空白”表以外，其他的工作表还处于深度隐藏的状态，如图所示，这样就达到强制用户启用宏的效果，当然这还需要VBA工程保护的配合。

 

第2部分Worksheet（工作表）对象
技巧29 防止更改工作表的名称 工作表的名称显示在工作表标签上，除了在相应的功能菜单中可以对其进行重命名操作外，在工作表标签上双击鼠标也能修改工作表名称。
一旦修改了工作表名称，可能就会产生一连串的问题，例如在其他工作簿中对该工作表的引用将会失效，通过工作表名称引用工作表的代码也将出错。
        Excel没有提供修改工作表名称的相关事件，要禁止用户修改工作表名称，需采取其他一些技巧。
比如在工作表BeforeClose事件中检验工作表名称，如果工作表名称不是指定的字符串，则将其修改为指定字符串，即保持工作表名称不变，代码如下。

  Private Sub Workbook_BeforeClose(Cancel As Boolean)
      If Sheet1.Name <> "Excel Home" Then Sheet1.Name = "Excel Home"
      ThisWorkbook.Save
  End Sub
       工作簿的BeforeClose事件过程，在关闭当前工作簿时判断Sheet1工作表名称，如果不是指定的字符串“Excel Home”，则将其恢复为“Excel Home”后保存工作簿，从而避免更改Sheet1工作表名称。

 

第2部分Worksheet（工作表）对象
技巧30 工作表中一次插入多行 在工作表的中插入多行空行，需要使用Insert方法，如下面的代码所示。

  Sub InSertRows_1()
      Dim i As Integer
      For i = 1 To 3
          Sheet1.Rows(3).Insert
      Next
  End Sub
I nSertRows_1过程使用Insert方法在如图所示的数据区域的第2行和第3行之间插入三行空行。

       Insert方法应用于Range对象时在工作表或宏表中插入一个单元格或单元格区域，其他单元格作相应移位以腾出空间，语法如下：
expression.Insert(Shift, CopyOrigin)
       参数expression是必需的，该表达式返回一个Range对象。
        参数Shift是可选的，指定单元格的移动方向。
可为以下XlInsertShiftDirection常量之一：xlShiftToRight或xlShiftDown。
如果省略本参数，Microsoft Excel将依据该区域的形状决定移动方向。
        参数CopyOrigin是可选的，复制的起点。
        还可以使用引用多行的方法，如下面的代码所示。

  Sub InSertRows_2()
      Sheet2.Range("A3").EntireRow.Resize(3).Insert
  End Sub
       InSertRows_2过程通过引用多行区域的方法实现一次插入多行。
        第2行代码中的Range(“A3”).EntireRow属性返回Range(“A3”)单元格所在的一整行，然后使用Resize属性调整行数后插入三行空行。
        也可以直接指定相应行再调整行数后插入空行，如下面的示例代码：
  Sub InSertRows_3()
      Sheet3.Rows(3).Resize(3).Insert
  End Sub

 

1

征婚启事
第2部分Worksheet（工作表）对象
技巧31 删除工作表中的空行 如果需要删除如图所示的工作表中所有的空行，可以使用下面的代码。

  Sub DelBlankRow()
      Dim rRow As Long
      Dim LRow As Long
      Dim i As Long
      rRow = Sheet1.UsedRange.Row
      LRow = rRow + Sheet1.UsedRange.Rows.Count - 1
      For i = LRow To rRow Step -1
          If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
              Rows(i).Delete
          End If
      Next
  End Sub
       DelBlankRow过程删除工作表中已使用的区域的所有空行。
        第5行代码获得工作表中已使用区域的首行行号，其中使用UsedRange属性返回工作表中已使用的区域。
        第6行代码获得工作表中已使用区域的最后一行行号。
        第7行到第11行代码从最大行数至最小行数循环判断指定行是否为空行，若为空行则删除该行。
        注意 此处一定要从最大行数至最小行数开始循环判断，因为如果工作表中存在两行及两行以上的相邻空行，从最小行数开始循环删除的话，当第一行空行被删除后，被删除行下面的一行会往上移位，而此时For...Next循环的计数器已经加1，所以会出现漏删除的现象。
        其中第8、9行代码使用工作表CountA函数判断当前行已使用单元格的数量，如果为零说明此行是空行则使用Delete删除。
        应用于Range对象的Delete方法删除对象，语法如下：
expression.Delete(Shift) 参数expression是必需的，返回一个Range对象。
        参数Shift是可选的，指定删除单元格时替补单元格的移位方式。
可为以下 XlDeleteShiftDirection常量之一：xlShiftToLeft或xlShiftUp。
如果省略该参数，则Microsoft Excel将根据区域的图形决定移位方式。
        运行DelBlankRow过程工作表区域如图所示。

 

第2部分Worksheet（工作表）对象
技巧32 删除工作表的重复行 在实际应用中，可能需要删除如图所示的工作表中A列的重复内容而只保留一行，那么可以借助工作表CountIf函数来完成，如下面的代码所示。

  Sub DeleteRow()
      Dim R As Integer
      Dim i As Integer
      With Sheet1
          R = .[a65536].End(xlUp).Row
          For i = R To 1 Step -1
              If WorksheetFunction.CountIf(.Columns(1), .Cells(i, 1)) > 1 Then
                  .Rows(i).Delete
              End If
          Next
      End With
  End Sub
       DeleteRow过程删除工作表A列重复单元格所在的整行内容，只保留一行。
        第5行代码取得工作表中A列的最后一个非空单元格的行号，关于Range对象的End属性请参阅技巧3 。
        第6行到第10行代码从最大行数至最小行数循环判断A列单元格内容是否重复并删除重复单元格所在的整行。
和技巧32 一样，此处For...Next循环也要从最大行数至最小行数开始循环判断，否则可能会删除不净。
其中第7行代码使用工作表CountIf函数判断单元格内容是否重复，如果重复则删除该单元格所在的行。
        运行DeleteRow过程工作表区域如图所示。

第2部分Worksheet（工作表）对象
技巧33 定位删除特定内容所在的行 如果需要删除如图所示的工作表区域中特定内容所在的行，可以使用定位的方法快速删除，无需使用For...Next循环对单元格逐个进行判断。

示例代码如下：
  Sub SpecialDelete()
      Dim R As Integer
      With Sheet1
          R = .Range("a65536").End(xlUp).Row
          .Range("a2:a" & R).Replace "Excel", "", 2
          .Columns(1).SpecialCells(4).EntireRow.Delete
      End With
  End Sub
       SpecialDelete过程删除工作表A列单元格中显示为“Excel”的行。
        第5行代码使用Replace方法将工作表A列中显示为“Excel”的单元格内容替换成空白。
关于Replace方法请参阅技巧6 。
        第6行代码使用SpecialCells方法定位到工作表A列中所有的空单元格，使用Range对象的EntireRow属性返回其所在的整个行一次性删除。
关于SpecialCells方法请参阅技巧4 。
        运行SpecialDelete过程工作表区域如图所示。

 

第2部分Worksheet（工作表）对象
技巧34 判断是否选中整行 通过当前选择的单元格区域的单元格数目与行数或列数相比较，判断用户是否选中了整行或整列，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      If Target.Rows.Count = 1 Then
          If Target.Columns.Count = 256 Then
              MsgBox "您选中了整行,当前行号" & Target.Row
          End If
      End If
  End Sub
       工作表的SelectionChange事件，判断用户是否选中了工作表中一整行单元格区域。
        第2行代码中的Target.Rows.Count返回目标区域的行数，确定用户当前选择区域的总行数是否为1。
        第3行代码中的Target.Columns.Count返回目标区域的列数，确定用户当前选择区域总列数是否为256。
        第4行代码当用户选中一整行时显示一个消息框，提示用户当前选择的行号，如图所示。

第2部分Worksheet（工作表）对象
技巧35 限制工作表的滚动区域 如果希望限制工作表中滚动的区域，可以通过设置WorkSheet对象的ScrollArea属性来实现。
ScrollArea属性使用以A1样式的区域引用形式（字符串类型）返回或设置工作表允许滚动的区域。
当设置了工作表滚动区域之后，用户不能选定滚动区域之外的单元格，但仍然可以选定区域之外的其他对象（例如图形、按钮等），同时工作表的一些相应功能可能被禁止（例如工作表全选、选中整行或整列等）。
 在VBE中的工程管理窗口选择相应工作表对象，然后在其属性窗口中设置ScrollArea属性，即可限制工作表中滚动的区域，如图所示。

       但是Excel不会记忆该项设置，当再次打开该工作簿时，ScrollArea属性将被重置，用户必须重新设置ScrollArea属性才能限制工作表中的滚动区域，解决方法是使用代码在工作簿打开时对ScrollArea属性进行设置，如下面的代码所示。

  Private Sub Workbook_Open()
      Sheet1.ScrollArea = "B4:H12"
  End Sub
       工作簿的Open事件，在打开该工作簿时设置Sheet1工作表的滚动区域为“B4:H12”单元格区域。
        如果需要取消滚动区域的限制，可以将ScrollArea属性值设置为空，如下面的代码所示。
 Sheet1.ScrollArea = ""

第2部分Worksheet（工作表）对象
技巧36 复制自动筛选后的数据区域 用户在对如图所示的数据列表进行自动筛选后，往往希望将自动筛选的结果复制到其它地方。

       这时可以通过获取该列表区域中可见单元格的方法得到筛选结果的单元格区域，并复制到工作表Sheet2中，如下面的代码所示。

  Sub CopyFilter()
      Sheet2.Cells.Clear
      With Sheet1
          If .FilterMode Then
              .AutoFilter.Range.SpecialCells(12).Copy Sheet2.Cells(1, 1)
          End If
      End With
  End Sub
       CopyFilter过程将Sheet1表中的筛选结果复制到工作表Sheet2中。
        第2行代码清除Sheet2表中数据。
        第4行代码判断Sheet1表是否处于自动筛选状态。
FilterMode属性返回工作表是否处于筛选模式，如果指定工作表中包含已筛选序列且该序列中含有隐藏行，则该值为True。
        第5行代码通过AutoFilter对象的Range属性返回工作表的自动筛选列表区域，再使用SpecialCells方法获取该列表区域中可见单元格（SpecialCells方法请参阅技巧4 ），得到筛选结果的单元格区域，然后使用Copy方法将结果区域复制到工作表Sheet2中，应用于Range对象的Copy方法将单元格区域复制到指定的区域或剪贴板中，语法如下：
expression.Copy(Destination) 参数expression是必需的，该表达式返回一个Range对象。
        参数Destination是可选的，指定区域要复制到的目标区域。
如果省略该参数，则将该区域复制到剪贴板中。
        运行CopyFilter过程工作表Sheet2如图所示。

第2部分Worksheet（工作表）对象
技巧37 使用高级筛选获得不重复记录 在如图所示的数据列表中，如果要将其中不重复的记录复制到另一工作表中，则可以通过高级筛选功能实现。

       示例代码如下：
  Sub Filter()
      Sheet1.Range("A1").CurrentRegion.AdvancedFilter _
          Action:=xlFilterCopy, Unique:=True, _
          CopyToRange:=Sheet2.Range("A1")
  End Sub
       Filter过程使用AdvancedFilter方法对单元格A1的当前区域筛选不重复的记录，并将筛选结果复制到工作表Sheet2中。
应用于Range集合的AdvancedFilter方法语法如下：
AdvancedFilter(Action, CriteriaRange, CopyToRange, Unique) 参数Action是必需的，可以为表格所列的 XlFilterAction常量之一。

       参数CriteriaRange指定高级筛选操作的条件区域，缺省时表示没有条件限制。
     参数CopyToRange表示指定被复制行的目标区域，仅当Action为xlFilterCopy时有效，否则忽略本参数。
     参数Unique指示是否选择不重复的记录，如果其值为True，则重复出现的记录仅保留一条；如果其值为 False（默认值），则筛选出所有符合条件的记录。
     运行FilterUnique过程，结果如图所示。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=8
第2部分Worksheet（工作表）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧38 工作表的保护与解除保护 在实际应用中，Excel编制的报表、表格、程序等，往往在单元格中设置了公式、函数、自定义格式等，为了防止在使用过程中修改或无意中修改这些设置，一般使用Excel的工作表保护功能来保护这些设置。
        但是程序中可能会使用代码对受保护的工作表进行操作，此时如果没有解除工作表保护，运行出现错误，如图所示。

       解决方法是在运行操作工作表的代码前先使用代码解除工作表保护，待操作完毕后再保护工作表，如下面的代码所示。

  Sub ShProtect()
      With Sheet1
          .Unprotect Password:="12345"
          .Cells(1, 1) = 100
          .Protect Password:="12345"
      End With
  End Sub
       ShProtect过程在受保护的工作表中对单元格进行操作，其中第3行代码使用Unprotect方法解除工作表的保护。
应用于Worksheet 对象的Unprotect方法解除工作表的保护，如果工作表不是受保护的，则此方法不起作用，所以在解除之前无需判断工作表是否受保护，其语法如下：
expression.Unprotect(Password) 参数expression是必需的，该表达式返回一个Worksheet 对象。
        参数Password是可选的，指定用于解除工作表的保护的密码，此密码是区分大小写的。
        第4、5行代码在单元格录入数据后使用Protect方法重新保护工作表。
应用于Worksheet对象的Protect方法保护工作表使其不至被修改，语法如下：
expression.Protect(Password, DrawingObjects, Contents, Scenarios, UserInterfaceOnly, AllowFormattingCells, AllowFormattingColumns, AllowFormattingRows, AllowInsertingColumns, AllowInsertingRows, AllowInsertingHyperlinks, AllowDeletingColumns, AllowDeletingRows, AllowSorting, AllowFiltering, AllowUsingPivotTables) 其中参数expression是必需的，该表达式返回一个Worksheet对象。
        参数Password是可选的，为一个字符串，该字符串为工作表指定区分大小写的密码。
        其他参数都是可选参数，其功能等同于如图所示的工作表保护对话框中的各项选项，具体请参阅VBA帮助。

       如果一个Excel文件使用时间过长，忘记了工作表保护时设置的密码，那么也可以使用VBA解除工作表的保护，代码如下：
  Sub RemoveShProtect()
      Dim i1 As Integer, i2 As Integer, i3 As Integer
      Dim i4 As Integer, i5 As Integer, i6 As Integer
      Dim i7 As Integer, i8 As Integer, i9 As Integer
      Dim i10 As Integer, i11 As Integer, i12 As Integer
      On Error Resume Next
      If ActiveSheet.ProtectContents = False Then
          MsgBox "该工作表没有保护密码！"
          Exit Sub
      End If
      For i1 = 65 To 66: For i2 = 65 To 66: For i3 = 65 To 66
      For i4 = 65 To 66: For i5 = 65 To 66: For i6 = 65 To 66
      For i7 = 65 To 66: For i8 = 65 To 66: For i9 = 65 To 66
      For i10 = 65 To 66: For i11 = 65 To 66: For i12 = 32 To 126
          ActiveSheet.Unprotect Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) _
          & Chr(i6) & Chr(i7) & Chr(i8) & Chr(i9) & Chr(i10) & Chr(i11) & Chr(i12)
          If ActiveSheet.ProtectContents = False Then
              MsgBox "已经解除了工作表保护！"
              Exit Sub
          End If
      Next: Next: Next: Next: Next: Next
      Next: Next: Next: Next: Next: Next
  End Sub
       RemoveShProtect过程解除工作表的保护。
        其中第7行到第10行代码判断工作表是否受保护，ProtectContents属性返回工作表的保护状态，如果工作表的内容处于保护状态，则该值为True。
        第11行到第22行代码使用For...Next 语句和Chr函数来返回指定字符码所代表的字符串组合不断地尝试解除工作表保护，一旦工作表的ProtectContents属性返回False说明已经解除工作表保护。

 

压缩文件名是 技巧38 实际xls文件是 技巧39, 希望改动一下,保持连贯,谢谢
谢谢提醒，已经改好重新上传了。

这是从网上找来的代码，解除活动工作表的保护，用了那么多的For...Next 语句就是穷举法，不断地尝试解除工作表保护直到解开为止。
在代码中用Chr函数来返回指定字符码所代表的字符，至于i1到i11是65到66，说实话我也有点奇怪，字符集中应该是32到126，65是A，66是B。
请知道的朋友解释一下。

1

征婚启事
这样一点也不方便看,编辑好打包给大家下载才是王道~~~
因为是边整理边更新的，所以没法一下子打包给大家下载，每一部分完成后都有这部分内容的附件和已完成的Word文档供大家下载，具体请看二楼往下的链接内容。

第2部分Worksheet（工作表）对象
技巧39 奇偶页打印 在Excel中却没有提供打印奇数页和偶数页的功能，用户可以使用VBA在Excel中实现该功能，如下面的代码所示。

  Sub PrintOddPage()
      Dim TotalPg As Integer
      TotalPg = ExecuteExcel4Macro("GET.DOCUMENT(50)")
      For i = 1 To TotalPg Step 2
          ActiveSheet.PrintOut From:=i, To:=i
      Next
  End Sub
       PrintOddPage过程打印活动工作表的奇数页内容，其中第3行代码使用ExecuteExcel4Macro方法执行Excel 4.0宏表函数获取总页数，通过该函数获取总页数而无需判断分页符。
        第4行到第6行代码使用For...Next 语句和PrintOut方法逐页打印所有的奇数页，PrintOut方法打印指定对象，语法如下：
expression.PrintOut(From, To, Copies, Preview, ActivePrinter, PrintToFile, Collate, PrToFileName) 参数expression是必需的，一个有效的对象。
        其他参数都是可选的，其中参数From指定打印的开始页号，如果省略该参数，将从起始位置开始打印；参数To指定打印的终止页号，如果省略该参数，将打印至最后一页。
        如果需要对活动工作表的偶数页进行打印，只需将第4行代码中的For...Next循环计数器的初值由1改为2即可。

 

第2部分Worksheet（工作表）对象的附件和第1、2部分的Word文档。

 

袁版，第2部分WORD文档的目录有点问题，出现了很多“错误！未定义书签”，是不是你把所有目录都做好了，但没有对应的文档。
 还有，WORD第2部分的技巧32开始，目录与网页上有点出入。

我试了下,一切正常啊。

你转到页面视图看看~ 1、技巧33和技巧35出现“错误！未定义书签。
” 2、技巧40 保护所有工作表 网页上没有
我明白了，是Word的目录有问题，这是修改前的，忘记了更新，抱歉，已更新了，或者在目录上[右键]》[更新域]就能修改为正确的目录，谢谢Hoer。

第3部分 Wordbook（工作簿）对象
技巧40 工作簿的引用方法 VBA中，在不同的工作簿之间转换需要指定引用的工作簿，通常有下面几种方法。

40-1 使用工作簿的名称

工作簿名称是指Excel文件的文件名，可以使用Workbooks集合引用方式来引用工作簿，如下面的代码所示。

  Sub WbQuote_1()
      MsgBox "路径为：" & Workbooks("技巧40 工作簿的引用方法.xls").Path
  End Sub
       WbQuote_1过程显示工作簿“技巧40 工作簿的引用方法.xls”的路径。
应用于Workbook对象的Path属性将完整路径返回给应用程序，语法如下：
expression.Path 参数expression是必需的，一个有效的对象。
        运行WbQuote_1过程结果如图所示。

40-2 使用工作簿的索引号

工作簿索引号是指工作簿打开的顺序，Excel根据工作簿打开的顺序以1开始进行编号。
下面的代码显示应用程序打开的第一个工作簿的名称。

  Sub WbQuote_2()
      MsgBox "第一个打开的工作簿名字为：" & Workbooks(1).Name
  End Sub
       WbQuote_2过程显示应用程序打开的第一个工作簿的名称。
应用于Workbook对象的Name属性返回对象的名称，语法如下：
expression.Name 参数expression是必需的，一个有效的对象。
        运行WbQuote_2过程，如果本工作簿是第一个打开的，结果如图所示。

       如果需要返回包含完整路径的工作簿名称则使用Workbook对象的FullName属性，如下面的代码所示。

  Sub WbQuote_3()
      MsgBox "包括完整路径的工作簿名称为：" & Workbooks(1).FullName
  End Sub
       运行WbQuote_3过程，如果本工作簿是第一个打开的，结果如图所示。

40-3 使用ThisWorkbook

使用ThisWorkbook属性返回当前宏代码运行的工作簿，如下面的代码所示。

  Sub WbQuote_4()
      ThisWorkbook.Save
  End Sub
       WbQuote_4过程使用Save方法保存当前宏代码运行的工作簿所做的更改。
        ThisWorkbook属性返回一个Workbook对象，该对象代表当前宏代码运行的工作簿。
        应用于Workbook对象的Save方法保存指定工作簿所做的更改。
        注意 本属性仅可在 Microsoft Excel内使用。
不能使用此属性访问任何其他应用程序的工作簿。

40-4 使用ActiveWorkbook

使用ActiveWorkbook代表活动窗口（最上面的窗口）的工作簿，如下面的代码所示。

  Sub WbQuote_5()
      MsgBox "当前活动工作簿名字为：" & ActiveWorkbook.Name
  End Sub
       WbQuote_5过程显示活动工作簿的名称，ActiveWorkbook属性返回一个Workbook对象，该对象代表活动窗口（最上面的窗口）的工作簿。
如果没有打开任何窗口或者活动窗口为信息窗口或剪贴板窗口，则返回Nothing。
        运行WbQuote_5过程结果如图所示。

 

3

吃撑De三文鱼
征婚启事
seki_100
版主，很想在EXCEL 中读取井号来从ORACLE 中提取数据，如何用VBA实现，请给与菜鸟指点
不好意思，oracle数据库没有涉及过，不了解。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=9
第3部分 Wordbook（工作簿）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧41 新建工作簿文件 在VBA中使用Add方法新建工作簿，如下面的代码所示。

  Sub AddNowbook()
      Dim Nowbook As Workbook
      Dim ShName As Variant
      Dim Arr As Variant
      Dim i As Integer
      Dim myNewWorkbook As Integer
      myNewWorkbook = Application.SheetsInNewWorkbook
      ShName = Array("余额", "单价", "数量", "金额")
      Arr = Array("01月", "02月", "03月", "04月", "05月", "06月", "07月", "08月", "09月", "10月", "11月", "12月")
      Application.SheetsInNewWorkbook = 4
      Set Nowbook = Workbooks.Add
      With Nowbook
          For i = 1 To 4
              With .Sheets(i)
                  .Name = ShName(i - 1)
                  .Range("B1").Resize(1, UBound(Arr) + 1) = Arr
                  .Range("A2") = "品名"
              End With
          Next
          .SaveAs Filename:=ThisWorkbook.Path & "" & "存货明细.xls"
          .Close Savechanges:=True
      End With
      Set Nowbook = Nothing
      Application.SheetsInNewWorkbook = myNewWorkbook
  End Sub

代码解析： AddNowbook过程使用Add方法建立新的工作簿并对新建工作簿进行操作。
        第2行到第6行代码声明变量类型。
        第7行代码保存Excel自动插入到新工作簿中的工作表数目。
        第8、9行代码将数组元素赋值给变量。
        第10行代码将Application对象的SheetsInNewWorkbook属性设置为4，在新建工作簿时插入4张工作表。
        第11行代码使用Add方法建立新的工作簿，应用于Workbooks对象的Add方法新建工作簿，新建的工作簿将成为活动工作簿。
        第12行到第22行代码操作新建工作簿。
其中第15行到第17行代码将新建工作簿的工作表进行重命名并给单元格赋值。
第20行代码使用SaveAs方法将新建工作簿重命名为“存货明细.xls”保存在同一目录中。
第21行代码使用Close方法关闭工作簿。
        第24行代码恢复工作簿的默认设置。
        运行AddNowbook过程将在工作簿同一目录中新建“存货明细.xls”工作簿，新建工作簿格式如图所示。

       注意 本例中没有考虑工作簿同名因素，如果目录中已有“存货明细.xls”工作簿，运行时会显示如图所示的对话框，选择“是”即可，否则将会出错。

第3部分 Wordbook（工作簿）对象
技巧42 打开指定的工作簿 VBA中使用Open方法打开一个工作簿，如下面的代码所示。

  Sub Openfile()
      Dim x As Integer
      For x = 1 To Workbooks.Count
          If Workbooks(x).Name = "123.xls" Then
              MsgBox """123""工作簿已经打开!"
              Exit Sub
          End If
      Next
      Workbooks.Open ThisWorkbook.Path & "\123.xls"
  End Sub

代码解析： Openfile过程打开同一目录中的“123”工作簿。
        第3行代码利用Workbook对象的Count属性取得打开工作簿的数目，使用For...Next 语句遍历所有打开的工作簿。
遍历工作簿除了使用For...Next 语句外还可以使用For...Each...Next语句来遍历Workbook对象集合中的所有元素，请参阅技巧46-1。
        第4行到第8行代码遍历所有打开的工作簿，如果Workbook对象集合中存在“123”工作簿，说明“123”工作簿已打开，则显示一条如图 42 1所示的提示信息。

       第9行代码如果“123”工作簿没有被打开则使用Open方法打开“123”工作簿。
        Open方法应用于Workbooks 对象时打开一个工作簿，语法如下：
expression.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)
       参数expression是必需的，返回一个Workbooks对象 参数FileName是必需的，要打开的工作簿的文件名。
        参数UpdateLinks是可选的，指定文件中链接的更新方式。
如果省略本参数，则提示用户选择链接的更新方式。
否则，该参数的取值应为表格中的某个值。

       参数ReadOnly是可选的，如果该值为True，则以只读模式打开工作簿。
        参数Format是可选的，如果Microsoft Excel正在打开一个文本文件，则该参数用于指定分隔字符，如表格所示。
如果省略本参数，则使用当前的分隔符。

       参数Password是可选的，该字符串指定打开一个受保护工作簿的密码。
如果省略该参数并且指定工作簿已设置密码，则提示用户输入密码。
        参数WriteResPassword是可选的，该字符串为一个写保护工作簿的写入权密码。
如果省略该参数并且指定工作簿已设置密码，则提示用户输入密码。
        参数IgnoreReadOnlyRecommended是可选的，如果该值为True，则设置Microsoft Excel不显示建议只读消息（如果该工作簿以“建议只读”选项保存）。
        参数Origin是可选的，如果文件为文本文件，则该参数用于指示该文件来源于何种操作系统。
        参数Delimiter是可选的，如果该文件为文本文件并且Format参数为 6，则此参数用于指定用作分隔符的字符。
        参数Editable是可选的，如果该文件为Microsoft Excel 4.0加载宏，则该参数的值为True时可打开该加载宏以便在窗口中看到。
如果该参数的值为False或者省略该参数，则该加载宏以隐藏方式打开，并且无法设为可见。
        参数Notify是可选的，当该文件不能以可读写模式打开时，如果该参数的值为True，则可将该文件添加到文件通知列表。
        参数Converter是可选的，打开文件时试用的第一个文件转换器的索引号。
        参数AddToMru是可选的，如果该值为True，则将该工作簿添加到最近使用的文件列表中。
默认值为False。
        参数Local是可选的，如果该值为True，则以Microsoft Excel（包括控制面版设置）的语言保存文件。
如果该值为False（默认值），则以 Visual Basic for Applications (VBA)的语言保存文件，其中Visual Basic for Applications (VBA)为典型安装的美国英语版本，除非VBA项目的Workbooks.Open来自旧的国际化的XL5/95 VBA项目。
        参数CorruptLoad是可选的，可为以下常量之一：xlNormalLoad、xlRepairFile 和 xlExtractData。
如果未指定任何值，则默认值通常为普通状态。

第3部分 Wordbook（工作簿）对象
技巧43 判断指定工作簿是否打开

43-1 遍历Workbooks集合方法

通过遍历当前应用程序所有已打开的工作簿文件(Workbooks集合)，判断指定名称的工作簿是否打开，如下面的代码所示。

  Sub WorkbookIsOpen_1()
      Dim Wb As Workbook
      Dim myWb As String
      myWb = "Excel Home.xls"
      For Each Wb In Workbooks
          If Wb.Name = myWb Then
              MsgBox "工作簿" & myWb & "已经被打开!"
              Exit Sub
          End If
      Next
      MsgBox "工作簿" & myWb & "没有被打开!"
  End Sub

代码解析： WorkbookIsOpen_1过程通过遍历当前应用程序中所有已打开的工作簿文件(Workbooks集合)，判断“Excel Home”工作簿是否打开。
        第5行代码使用For...Each...Next语句来遍历Workbook对象集合中的所有元素。
        第6行到第8行代码如果Workbook对象集合包含“Excel Home.xls”工作簿名称，说明文件已打开，使用Exit Sub语句结束代码的运行。
        第11行代码如果运行到此行代码说明“Excel Home.xls”工作簿没有被打开。

43-2 错误处理方法

       使用错误处理程序判断指定名称的工作簿是否打开，如下面的代码所示。

  Sub WorkbookIsOpen_2()
      Dim Wb As Workbook
      Dim myWb As String
      myWb = "Excel Home.xls"
      Err.Clear
      On Error GoTo line
      Set Wb = Application.Workbooks(myWb)
      MsgBox "工作簿" & myWb & "已经被打开!"
      Set Wb = Nothing
      Exit Sub
  line:
      MsgBox "工作簿" & myWb & "没有被打开!"
      Set Wb = Nothing
  End Sub

代码解析： WorkbookIsOpen_2过程使用错误处理程序判断“Excel Home”工作簿是否打开。
        第5行代码使用Clear方法清除Err对象的所有属性设置。
        第6行代启动错误处理程序，如果第7行代码发生错误则执行line行后面的代码。
        第7行代码使用Set语句将Workbook对象引用赋给变量Wb，如果 “Excel Home.xls”工作簿没有被打开将发生下标越界错误，此时执行第12、13行代码，否则执行第8、9行代码。

第3部分 Wordbook（工作簿）对象
技巧44 禁用宏则关闭工作簿 通常情况下，当应用程序的宏安全性的安全级别设置为“中”时，打开包含Microsoft Excel 4.0版的宏的工作簿，将显示如图1所示的“安全警告”对话框。

       图1 如果用户选择“禁用宏”按钮，则会显示如图2所示的警告消息框，当用户选择“否”时，不能打开该工作簿；用户选择“是”时，打开该工作簿，但VBA宏被禁止，而Microsoft Excel 4.0版的宏未被禁止。

       图2 我们可以利用禁用VBA宏不能禁止Microsoft Excel 4.0版的宏这个特点，使用Microsoft Excel 4.0版的宏来实现禁用宏则关闭工作簿的功能。
        步骤1 新建或打开需要添加此项功能的工作簿文件。
        步骤2 按<Ctrl+F11>组合键为工作簿添加一个宏表，添加的宏表名称默认为“Macro1”。
        步骤3 在宏表“Macro1”的A1至A7单元格中输入下面的内容。

  禁用宏则关闭工作簿
  =ERROR(FALSE)
  =IF(ERROR.TYPE(RUN("TestMacro"))=4)
  = ALERT("因禁用了宏功能,文件将被关闭!",3)
  = FILE.CLOSE(FALSE)
  =END.IF()
  =RETURN()

       图3 代码解析： Microsoft Excel 4.0宏函数以等号（=）开始，其他不是由等号开始的内容将被视作注释。
通常用作定义的宏名称或者作为宏函数实现功能的注释内容设置为斜体字样以示区别，如图3中单元格A1所示。
        第2行代码关闭错误检查功能。
如果关闭错误检查，那么当宏执行遇到错误时，Microsoft Excel 将不予理会而继续执行。
        第3行到第6行代码使用If函数与End.If函数构成条件判断语句。
其中，第3行中的语句通过检查宏函数RUN("TestMacro")的返回错误类型是否为4（禁用宏时的返回结果），判断工作簿是否禁用了宏功能。
如果第3行的结果为True，则执行下面的语句。
        在第4、5行代码，插入几个空格来表示相关代码之间的层次结构。
第4行中的代码显示一个消息框。
第5行中的代码关闭当前活动工作簿，设置参数值为Fasle表示关闭时工作簿时不保存对其所作的更改。
 第7行代码终止当前代码的执行。
Microsoft Excel 4.0宏要求每个宏必须使用RETURN或HALT函数结束。
        步骤4 为每个表添加工作表级别的名称“Auto_Activate”，并将引用都指向宏表“Macro1”的A2单元格。
“Auto_Activate”是一个自动宏，表被激活时自动执行。
        添加工作表级别的名称的方法如下：选择一张工作表，假设为表“Sheet1”，单击菜单“插入”→“名称”→“定义名称”。
在“定义名称”对话框中添加名称，如图4所示。

       图4 输入完成后单击“确定”按钮，完成一张工作表的“Auto_Activate”的定义。
完成定义后的名称将在“定义名称”对话框中显示，如图5所示。
依次为每个表添加“Auto_Activate”名称。

       图5 此外，使用VBA也可以实现同样的操作，并且使用VBA的好处是能够隐藏名称，以避免名称被删除或修改。
代码如下：
  Sub AddPrivateNames()
      Dim sht As Object
      For Each sht In Sheets
          ThisWorkbook.Names.Add sht.Name & "!Auto_Activate", _ "=Macro1!$A$2", False
      Next
  End Sub

  Sub HideMacroSheet()
      ThisWorkbook.Excel4MacroSheets(1).Visible = xlSheetHidden
  End Sub
       当应用程序的宏安全性的安全级设置为“中”时，如果用户打开该工作簿文件并选择“禁用宏”，将显示如图 2所示的警告消息框。
当用户选择“是”时，活动工作表上的自动宏“Auto_Activate”将被执行，执行结果显示如图6所示的消息框，当用户选择“确定”按钮后，将强制关闭该工作簿文件。

       图6

点评
bluexuemei
这部分有点难理解,做个记号!

2

征婚启事
forverd
第3部分 Wordbook（工作簿）对象
技巧45 关闭工作簿不显示保存对话框 当用户更改工作簿后，没有进行保存操作而直接关闭工作簿时，将显示如图所示的消息框，提示用户是否保存对工作簿的更改，如果希望不显示该消息框而直接关闭关闭工作簿，可以在关闭时进行相应的设置。

45-1 使用Close方法关闭工作簿

使用Close方法关闭工作簿的，可以在Close方法中指定相应的参数，如下面的代码所示。

  Sub wbClose_1()
      ThisWorkbook.Close SaveChanges:=False
  End Sub
       wbClose_1过程使用Close方法关闭工作簿，并放弃所有对工作簿的更改。
        应用于Workbook对象的Close方法关闭对象，语法如下：
expression.Close(SaveChanges, Filename, RouteWorkbook) 其中SaveChanges参数是可选的，如果工作簿没有改变则忽略此参数；如果工作簿发生了改变并且在另外的窗口中也打开了该工作簿，则仍然忽略此参数；如果工作簿发生了改变并且没有在另外的窗口中打开，则此参数将指定是否在工作簿中保存所发生的更改。
取值与操作如表格所示：
       如果希望在关闭工作簿时自动保存更改，将SaveChanges参数值设置为True即可。
        还可以在使用Close方法关闭工作簿时设置Workbook对象的Saved属性，如下面的代码所示。

  Sub wbClose_2()
      ThisWorkbook.Saved = True
      ThisWorkbook.Close
  End Sub
       wbClose_2过程使用Close方法关闭工作簿，并放弃所有对工作簿的更改。
        Workbook对象的Saved属性指示工作簿从上次保存至今是否发生过更改，如果工作簿进行了更改，则该属性值为False，否则为True。
应用程序在关闭工作簿之前判断该属性的值，如果其值为False，则显示提示是否保存的消息框，询问用户是否保存对工作簿所做的更改。
        第2行代码将该属性的值设置为True，使Excel认为已经保存了对工作簿所作的更改（实际上没有保存更改），从而不再显示提示是否保存的消息框。
        如果需要保存对工作簿所作的更改，那么应该在Close方法之前使用Save方法保存工作簿，代码如下：
  Sub wbClose_3()
      ThisWorkbook.Save
      ThisWorkbook.Close
  End Sub
       wbClose_3过程使用Save方法保存工作簿所做的更改，然后使用Close方法关闭工作簿。

45-2 单击工作簿关闭按钮关闭工作簿

如果是通过单击工作簿的关闭按钮等操作关闭工作簿的，则使用BeforeClose事件过程来控制，如下面的代码所示。

  Private Sub Workbook_BeforeClose(Cancel As Boolean)
       Me.Saved = True
  End Sub
       工作簿的Workbook_BeforeClose事件，将工作簿的Saved属性设置为True，不保存更改而直接关闭工作簿，且不显示提示保存的消息框。
        如果希望保存对工作簿的更改，则在Workbook_BeforeClose事件中使用Save方法保存工作簿，如下面的代码所示。

  Private Sub Workbook_BeforeClose(Cancel As Boolean)
      Me.Save
  End Sub

点评
bluexuemei
Workbook对象的Saved属性指示工作簿从上次保存至今是否发生过更改，如果工作簿进行了更改，则该属性值为False，否则为True。
应用程序在关闭工作簿之前判断该属性的值，如果其值为False，则显示提示是否保存的消息框，
第3部分 Wordbook（工作簿）对象
技巧46 禁用工作簿的关闭按钮 一般情况下，用户可以通过菜单“文件”→“关闭”、工作簿窗口右上角的“关闭窗口”按钮或者任务栏中图标右键菜单中的“关闭”菜单项关闭工作簿。
如果希望禁用上述关闭工作簿的功能，而只能通过代码关闭工作簿，则可以在相应的工作簿事件中实现，如下面的代码所示。

  Dim BClose As Boolean
  Private Sub Workbook_BeforeClose(Cancel As Boolean)
      If BClose = False Then
          Cancel = True
          MsgBox "此功能已经被禁止，请使用""关闭""按钮关闭工作簿!", vbExclamation, "提示"
      End If
  End Sub
  Public Sub CloseWorkbook()
      BClose = True
      Me.Close
  End Sub
       第1行代码在模块顶部声明变量BClose为Boolean类型，默认初始值为False。
        第2行到第7行代码工作簿的BeforeClose事件过程，通过变量BClose的当前值决定是否能够关闭工作簿，只有当BClose的值为True时，才允许关闭工作簿。
如果变量BClose的值为False时将参数Cancel的值设置为True，以禁止关闭操作。
        第8行到第11行代码CloseWorkbook过程，将变量BClose的当前值设置为True后使用Close方法关闭工作簿。
关于Close方法请参阅技巧45-1。
        在添加以上代码后，用户只能通过调用CloseWorkbook过程关闭工作簿。
如果通过菜单“文件”→“关闭”或者单击工作簿窗口右上角的“关闭窗口”按钮关闭工作簿，将显示如图所示的消息框。

第3部分 Wordbook（工作簿）对象
技巧47 保存工作簿的方法

47-1 使用Save方法

使用Workbook对象的Save方法保存工作簿的更改，如下面的代码所示。

  Sub SaveWork()
      ThisWorkbook.Save
  End Sub
       SaveWork过程保存代码所在的工作簿的修改。
        Save方法保存指定工作簿所做的更改，语法如下：
expression.Save 参数expression是必需的，该表达式返回一个Workbook对象。
        如果是第一次保存工作簿，请使用SaveAs方法为该文件指定文件名，请参阅技巧47-2。

47-2 直接保存为另一文件名

如果需要将工作簿另存为另一个文件名，可以使用Workbook对象的SaveAs方法，如下面的代码所示。

  Sub SaveAsWork()
      ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\123.xls"
  End Sub
       SaveAsWork过程将代码所在的工作簿保存为“123”工作簿文件。
        Workbook对象的SaveAs方法使用另外一个不同的文件名保存对工作簿所做的更改，语法如下：
SaveAs(FileName,FileFormat,Password,WriteResPassword,ReadOnlyRecommended,CreateBackup,AccessMode,ConflictResolution,AddToMru,TextCodepage,TextVisualLayout,Local) 其中，参数Filename可选，表示要保存文件的文件名的字符串。
可包含完整路径，如果不指定路径，将文件保存到当前文件夹中。
        使用SaveAs方法将工作簿另存为新文件后，将关闭原工作簿文件。

47-3 保存工作簿副本

如果用户希望工作簿在保存为另一文件名后，能继续编辑原工作簿，那么可以使用SaveCopyAs方法，如下面的代码所示。

  Sub SaveCopyWork()
      ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\123.xls"
  End Sub
       SaveCopyWork过程使用SaveCopyAs方法保存代码所在的工作簿副本，并指定其名称。
        SaveCopyAs方法将指定工作簿的副本保存到文件，但不修改内存中的打开工作簿，语法如下：
SaveCopyAs(Filename) 参数Filename是必需的，用于指定工作簿副本的文件名。

第3部分 Wordbook（工作簿）对象
技巧48 保存指定工作表为工作簿文件 如果需要将工作簿中的工作表单独保存为一个工作簿文件，可以使用Worksheet对象的Copy方法，将指定的工作表复制到一个新建的工作簿，如下面的代码所示。

  Sub SheetCopy()
      On Error GoTo line
      ActiveSheet.Copy
      ActiveWorkbook.Close SaveChanges:=True, Filename:=ThisWorkbook.Path & "\SheetCopy.xls"
      Exit Sub
  line:
      ActiveWorkbook.Close False
  End Sub
       SheetCopy过程将活动工作表单独保存为一个工作簿文件。
        第2行代码错误处理语句。
备份过程中，如果已存在同名工作簿，会出现如图所示的提示，如果选择了“否”或“取消”，此时新工作簿已经建立，在执行4行代码时发生错误，使程序中断，所以使用GoTo语句执行第7行代码，关闭新建立的工作簿并且不保存。

       第3行代码使用Copy方法新建一个工作簿，新工作簿中包含复制的工作表。
应用于Worksheet对象的Copy方法将指定工作表复制到工作簿的另一位置，语法如下：
Copy (Before, After) 其中，参数Before是可选的，用来指定工作表，复制的工作表将置于此工作表之前。
参数After是可选的，用来指定工作表，复制的工作表将置于此工作表之后。
        不能同时指定Before参数和After参数。
当Copy方法省略参数时，应用程序将新建一个空工作簿（新建工作簿将成为活动窗口），并将Copy方法引用的工作表复制到该空工作簿中。
        第4行代码使用Workbook对象的Close方法关闭新建的工作簿。
应用于Workbooks集合和Workbook对象的Close方法请参阅技巧45-1。
        如果需要将工作簿中的几个工作表单独保存为一个工作簿文件时，可以以数组的形式指定要复制的工作表，如下面的代码所示。

  Sub ArrSheetCopy()
      On Error GoTo line
      Worksheets(Array("Sheet1", "Sheet2")).Copy
      ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\ArrSheetCopy.xls"
      ActiveWorkbook.Close SaveChanges:=True
      Exit Sub
  line:
      ActiveWorkbook.Close False
  End Sub
       ArrSheetCopy过程将“Sheet1”和“Sheet2”工作表单独保存为一个工作簿文件。
        第4行代码使用SaveAs方法保存活动工作簿，关于SaveAs方法请参阅技巧47-2。

 

1

莫愁湖
第3部分 Wordbook（工作簿）对象
技巧49 打印预览时不触发事件 在工作表打印之前或进行打印预览时，会触发工作簿的BeforePrint事件。
在某些情况下希望在打印预览时能禁止触发该事件，例如如图所示的工作表中，用户在打印时使用下面的代码将流水号的数值自动加1。

  Private Sub Workbook_BeforePrint(Cancel As Boolean)
      Sheet1.Range("J1") = Sheet1.Range("J1") + 1
  End Sub

       但是在打印预览时并不希望流水号的数值自动加1，此时，需要修改系统的打印预览功能，如下面的代码所示。

  Private Sub Workbook_Open()
      Dim CmdCtrls As CommandBarControls
      Dim Cmd As CommandBarControl
      Set CmdCtrls = Application.CommandBars.FindControls(ID:=109)
      For Each Cmd In CmdCtrls
          Cmd.OnAction = "ThisWorkbook.MyPrint"
      Next
  End Sub
       工作簿的Open事件过程，在打开工作簿时，修改系统中所有打印预览命令按钮和菜单项的动作，指定其OnAction属性为ThisWorkbook代码窗口中的公用过程MyPrint。
        第4行代码使用FindControls方法将所有打印预览命令按钮和菜单项赋给变量CmdCtrls，FindControls方法返回符合指定条件的CommandBarControls集合，语法如下：
expression.FindControls(Type, Id, Tag, Visible) 其中参数expression是必需的，该表达式返回一个CommandBars集合。
        参数Id是可选的，要查找控件的标识符。
打印预览命令控件的标识符为109。
        第5行到第7行代码遍历所有打印预览命令控件，指定其OnAction属性为ThisWorkbook代码窗口中的公用过程MyPrint。
OnAction属性返回或设置一个Visual Basic 的过程名，该过程在用户单击或更改某命令栏控件的值时运行。
 MyPrint过程代码如下：
  Public Sub MyPrint()
      With Application
          .EnableEvents = False
          .ActiveSheet.PrintPreview EnableChanges:=False
          .EnableEvents = True
      End With
  End Sub
       MyPrint过程通过禁止对象事件，使工作表打印预览时不触发工作簿的BeforePrint事件。
        第3行代码将Application对象的EnableEvents属性设置为False，禁用事件，使事件不能触发。
        第4行代码使用PrintPreview方法对工作表执行打印预览。
PrintPreview方法以打印效果显示指定的对象，该方法只有一个参数EnableChanges，用来指定是否可以修改页面设置，当其值为False时，禁止在打印预览时修改页面设置，默认值为True。
        第5行代码将Application对象的EnableEvents属性设置为True，启用事件。
        为了在工作簿时恢复默认的打印预览设置，在ThisWorkbook代码窗口写入以下代码：
  Private Sub Workbook_BeforeClose(Cancel As Boolean)
      Dim CmdCtrls As CommandBarControls
      Dim Cmd As CommandBarControl
      Set CmdCtrls = Application.CommandBars.FindControls(ID:=109)
      For Each Cmd In CmdCtrls
          Cmd.OnAction = ""
      Next
  End Sub
       工作簿的BeforeClose事件过程，关闭工作簿时将所有打印预览命令按钮和菜单项的OnAction属性恢复为默认的动作。
        经过以上设置，工作表只有在进行打印时“流水号”数值才自动加1。

 

点评
bluexuemei
这个有点复杂,做个记号!

1

征婚启事
第3部分 Wordbook（工作簿）对象
技巧50 设置工作簿文档属性信息 使用DocumentProperties集合对象的BuiltinDocumentProperties属性可以设置文档的属性信息，如下面的代码所示。

  Sub WbBuiltin()
      With ThisWorkbook
          .BuiltinDocumentProperties("Title") = "Wordbook（工作簿）对象"
          .BuiltinDocumentProperties("Subject") = "设置工作簿的文档属性信息"
          .BuiltinDocumentProperties("Author") = "yuanzhuping"
          .BuiltinDocumentProperties("Company") = "tzzls"
          .BuiltinDocumentProperties("Comments") = "工作簿文档属性信息"
          .BuiltinDocumentProperties("Keywords") = "Excel VBA"
      End With
      MsgBox "工作簿文档属性信息设置完毕！"
  End Sub
       WbBuiltin过程设置代码所在工作簿的属性信息，应用于Workbook对象的BuiltinDocumentProperties属性返回一个DocumentProperties集合，该集合代表指定工作簿的所有内置文档属性，本属性返回的是内置文档属性的整个集合。
通过指定属性的名称或集合中的索引号返回集合中的单个成员（一个DocumentProperty对象）。
        第3行代码设置标题，第4行代码设置主题，第5行代码设置作者，第6行代码设置公司，第7行代码设置备注，第8行代码设置关键字。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=10
本帖已被收录到知识树中，索引项：开发帮助和教程
给我最尊重的版主挑个小瑕疵 版主说：“此方法（Address引用法）只适用于单个单元格或者加上OR运算符可以适用于几个单元格，多则不方便。
”，可我发现address属性也可以返回区域名，如A1:B2之类的呀！
不错，address属性可以返回区域，但是如果事件中代码改成这样的： If Target.Address(0, 0) = "A1:B1" Then 那就只有在选择A1和B1两个单元格的情况下才触发事件，选中其中一个是不会触发的。
如果希望选中A1或B1的情况下触发事件，代码只有这样： If Target.Address(0, 0) = "A1" Or Target.Address(0, 0) = "B1" Then 所以说多则不方便。

下载的手都酸了，也同时被版主的执着精神所感动，在此谢谢版主。
 我是将内容一一复制粘贴到WORD文档里面，请问有没有更快速下载的方法，
这个不需要复制粘贴到WORD文档里面，第一部分都有WORD文档供下载的，待完成后也会有完整的WORD文档供大家下载，如果有哪位朋友能制成电子书就更好了。

第3部分 Wordbook（工作簿）对象
技巧51 不打开工作簿取得其他工作簿数据 在Excel的使用过程中，经常需要引用其他工作簿的数据，而用户往往希望能在不打开工作簿或看似不打开工作簿的情况下取得其他工作簿中的数据，有以下几种方法可以实现。

51-1 使用公式

如果需要引用的数据不是太多，可以使用公式取得引用工作簿中的工作表数据，如下面的代码所示。

  Sub CopyData_1()
      Dim Temp As String
      Temp = "'" & ThisWorkbook.Path & "\[数据表.xls]Sheet1'!"
      With Sheet1.Range("A1:F22")
          .FormulaR1C1 = "=" & Temp & "RC"
          .Value = .Value
      End With
  End Sub
       CopyData_1过程在工作表中写入公式引用“数据表”中同一位置单元格中的数据。
        第3行代码将引用工作簿的路径赋给变量Temp。
        第5行代码在作表中写入公式引用数据。
        第6行代码将公式转换为数值。

51-2 使用GetObject函数

使用GetObject函数来获取对指定的Excel工作表的引用，如下面的代码所示。

  Sub CopyData_2()
      Dim Wb As Workbook
      Dim Temp As String
      Application.ScreenUpdating = False
      Temp = ThisWorkbook.Path & "\数据表.xls"
      Set Wb = GetObject(Temp)
          With Wb.Sheets(1).Range("A1").CurrentRegion
              Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
              Wb.Close False
          End With
      Set Wb = Nothing
      Application.ScreenUpdating = True
  End Sub
       CopyData_2过程使用GetObject函数来获取“数据表”工作簿中的数据。
        第4行代码关闭屏幕更新加快运行速度。
        第5行代码将引用工作簿的路径赋给变量Temp。
        第6行代码使用Set语句将GetObject函数返回的对象赋给对象变量Wb。
        GetObject函数返回文件中的ActiveX对象的引用，语法如下：
GetObject([pathname] [, class]) 参数pathname是可选的，包含待检索对象的文件的全路径和名称。
如果省略，则class参数是必需的。
        参数class是可选的，代表该对象的类的字符串。
        Class参数的格式为appname.objecttype，语法的各个部分如表格所示。

       第7行到第10行代码，当GetObject函数指定的对象被激活之后，就可以在代码中使用对象变量Wb来访问这个对象的属性和方法。
        其中第7、8行代码将“数据表”工作簿中的第1张工作表已使用区域的数据赋给本工作表的单元格，第9行代码关闭“数据表”工作簿，使用GetObject函数返回对象的引用时，虽然在窗口中看不到对象的实例，但实际上是打开的，所以需用Close语句将其关闭。
        第12行代码开启屏幕更新。

51-3 隐藏Application对象

通过隐藏Application对象来模拟不打开工作簿取数，如下面的代码所示。

  Sub CopyData_3()
      Dim myApp As New Application
      Dim Sh As Worksheet
      Dim Temp As String
      Temp = ThisWorkbook.Path & "\数据表.xls"
      myApp.Visible = False
      Set Sh = myApp.Workbooks.Open(Temp).Sheets(1)
      With Sh.Range("A1").CurrentRegion
          Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
      End With
      myApp.Quit
      Set Sh = Nothing
      Set myApp = Nothing
  End Sub
       CopyData_3过程隐藏Application对象来模拟不打开工作簿取数。
        第2行代码使用New关键字隐式地创建一个Application对象。
        第6行代码将新创建的Application对象的Visible属性设置为False，使之隐藏。
        第7行代码使用Open方法打开“数据表”工作簿（关于Open方法请参阅技巧42） ，因为工作簿是使用新创建的、隐藏的Application对象打开的，所以在窗口中是不可视的。
        第8行到第10行代码将“数据表”工作簿中的第1张工作表已使用区域的数据赋给本工作表的单元格。
        第11行代码使用Quit方法退出新打开的Excel程序。

51-4 使用ExecuteExcel4Macro方法

使用ExecuteExcel4Macro方法可以做到不打开工作表的情况下获取其他工作薄中指定工作表的数据，如下面的代码所示。

  Sub CopyData_4()
      Dim RCount As Long
      Dim CCount As Long
      Dim Temp As String
      Dim Temp1 As String
      Dim Temp2 As String
      Dim Temp3 As String
      Dim R As Long
      Dim C As Long
      Dim arr() As Variant
      Temp = "'" & ThisWorkbook.Path & "\[数据表.xls]Sheet1'!"
      Temp1 = Temp & Rows(1).Address(, , xlR1C1)
      Temp1 = "Counta(" & Temp1 & ")"
      CCount = Application.ExecuteExcel4Macro(Temp1)
      Temp2 = Temp & Columns("A").Address(, , xlR1C1)
      Temp2 = "Counta(" & Temp2 & ")"
      RCount = Application.ExecuteExcel4Macro(Temp2)
      ReDim arr(1 To RCount, 1 To CCount)
      For R = 1 To RCount
          For C = 1 To CCount
              Temp3 = Temp & Cells(R, C).Address(, , xlR1C1)
              arr(R, C) = Application.ExecuteExcel4Macro(Temp3)
          Next
      Next
      Range("A1").Resize(RCount, CCount).Value = arr
  End Sub
       CopyData_4过程使用ExecuteExcel4Macro方法获取“数据表”工作薄中指定工作表的数据。
        第14、16行代码使用ExecuteExcel4Macro方法执行Counta函数取得“数据表”工作薄中指定工作表的行数和列数合计。
        ExecuteExcel4Macro方法执行一个Microsoft Excel 4.0宏函数，然后返回此函数的结果，语法如下：
expression.ExecuteExcel4Macro(String) 参数expression是可选的，返回一个Application对象。
        参数String是必需的，一个不带等号的Microsoft Excel 4.0宏语言函数，所有引用必须是像R1C1这样的字符串。
        因为Microsoft Excel 4.0 宏不在当前工作簿或工作表的环境中求值，所有的引用都是外部引用，所以无需打开引用工作簿但是需要明确指定工作簿名称。
        第18行代码使用ReDim语句为动态数组arr重新分配存储空间。
        第19行到第24行代码循环取值，将“数据表”工作薄中指定工作表的数据赋给动态数组arr。
        第25行代码将动态数组arr的值赋给工作表的单元格。

51-5 使用SQL连接

使用SQL建立与工作簿的连接，查询数据记录后复制到当前工作表中，如下面的代码所示。

  Sub CopyData_5()
      Dim Sql As String
      Dim j As Integer
      Dim R As Integer
      Dim Cnn As ADODB.Connection
      Dim rs As ADODB.Recordset
      With Sheet5
          .Cells.Clear
          Set Cnn = New ADODB.Connection
          With Cnn
              .Provider = "microsoft.jet.oledb.4.0"
              .ConnectionString = "Extended Properties=Excel 8.0;" _
                  & "Data Source=" & ThisWorkbook.Path & "\数据表"
              .Open
          End With
          Set rs = New ADODB.Recordset
          Sql = "select * from [Sheet1$]"
          rs.Open Sql, Cnn, adOpenKeyset, adLockOptimistic
              For j = 0 To rs.Fields.Count - 1
                  .Cells(1, j + 1) = rs.Fields(j).Name
              Next
          R = .Range("A65536").End(xlUp).Row
          .Range("A" & R + 1).CopyFromRecordset rs
      End With
      rs.Close
      Cnn.Close
      Set rs = Nothing
      Set Cnn = Nothing
  End Sub
       CopyData_5过程使建立与“数据表”工作簿的连接，查询数据记录后复制到当前工作表中。
        第8行代码删除当前工作表的所有数据。
        第9行到第15行代码建立与“数据表”工作簿的连接。
        第16行到第24行代码查询“数据表”工作簿的全部数据，并复制到工作表中。
其中第20行代码将字段名称（标题行）复制到工作表中，第23行代码将查询到的数据记录复制到工作表。

点评
bluexuemei
使用ExecuteExcel4Macro方法和SQL有点复杂,做个记号

2

征婚启事
vv3509
还是不可以。

是否可以作为一个宏命令来运行？
代码中的Sheet6是工作表的代码名称,不是标签上的名称,从图上看你工作簿中没有Sheet6这张表.而标签名为Sheet6的工作表的CodeName属性为Sheet3,请参阅技巧21[引用工作表的方式]

第3部分 Wordbook（工作簿）对象
技巧52 返回窗口的可视区域地址 VBA中使用VisibleRange属性返回当前窗口的可视区域，如下面的代码所示。

  Sub VbRange()
      Dim s As String
      s = ActiveWindow.VisibleRange.Address(0, 0)
      MsgBox "窗口的可视区域为：" & s
  End Sub
       VbRange过程使用消息框显示当前窗口的可视区域的地址。
        应用于当前Window对象的VisibleRange属性返回一个Range对象，代表当前窗口的可视区域。
窗口的可视区域就是用户可以在窗口或窗格中看到的单元格区域，如果行或列部分可见，该行或列也包括在可视区域中。
        因为VisibleRange属性返回的是一个Range对象，因此可以直接使用该对象的属性和方法。
        当窗口的大小发生变化时，返回的可视区域的地址也会不同，如图所示。

PS：其实Window对象的VisibleRange属性不应放在工作簿对象一节中，因为个人认为Window对象的实用性不大，所以只整理了一个，就归在这了。

第3部分 Wordbook（工作簿）对象
第1部分到第3部分的Word文档及第3部分 Wordbook（工作簿）对象的附件。

 

技巧19 如果你選中幾個單元各就會出錯， 有什麽辦法解決呢？
我疏忽了，加个错误处理语句。
Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next Sheet1.Unprotect Password:="12345" If Target.Value <> "" Then Target.Locked = True Sheet1.Protect Password:="12345" End If End Sub

2

征婚启事
624859791
第4部分 Shape（图形）、Chart（图表）对象
技巧53 在工作表中添加图形 如果需要在工作表中添加图形对象，可以使用AddShape方法，如下面的代码所示。

  Sub AddShape()
      Dim myShape As Shape
      On Error Resume Next
      Sheet1.Shapes("myShape").Delete
      Set myShape = Sheet1.Shapes.AddShape(msoShapeRectangle, 40, 120, 280, 30)
      With myShape
          .Name = "myShape"
          With .TextFrame.Characters
              .Text = "单击将选择Sheet2!"
              With .Font
                  .Name = "华文行楷"
                  .FontStyle = "常规"
                  .Size = 22
                  .ColorIndex = 7
              End With
          End With
          With .TextFrame
              .HorizontalAlignment = -4108
              .VerticalAlignment = -4108
          End With
          .Placement = 3
      End With
      myShape.Select
      With Selection.ShapeRange
          With .Line
              .Weight = 1
              .DashStyle = msoLineSolid
              .Style = msoLineSingle
              .Transparency = 0
              .Visible = msoTrue
              .ForeColor.SchemeColor = 40
              .BackColor.RGB = RGB(255, 255, 255)
          End With
          With .Fill
              .Transparency = 0
              .Visible = msoTrue
              .ForeColor.SchemeColor = 41
              .OneColorGradient 1, 4, 0.23
          End With
      End With
      Sheet1.Range("A1").Select
      Sheet1.Hyperlinks.Add Anchor:=myShape, Address:="", _
          SubAddress:="Sheet2!A1", ScreenTip:="选择Sheet2!"
      Set myShape = Nothing
  End Sub
       AddShape过程在工作表中添加一个矩形并设置其外观等属性。
        第2行代码声明变量myShape的对象类型。
        第3、4行代码删除可以存在的名称为“myShape”的图形对象。
        第5行代码使用AddShape方法在工作表中添加一个矩形。
当该方法应用于Shapes对象时，返回一个Shape对象，该对象代表工作表中的新自选图形，语法如下：
expression.AddShape(Type, Left, Top, Width, Height) 参数expression是必需的，返回一个Shapes对象。
        参数Type是必需的，指定要创建的自选图形的类型。
        参数Left和Top是必需的，以磅为单位给出自选图形边框左上角的位置。
        参数Width和Height是必需的，以磅为单位给出自选图形边框的宽度和高度。
        第7行代码将新建图形命名为“myShape”，向Shapes集合添加新的图形时，将对新添加的图形赋以默认的名称，若要为图形指定更有意义的名称，可指定其Name属性。
        第8行到第16行代码为矩形添加文字，并设定其格式。
        其中第8行代码使用TextFrame 属性和Characters方法返回该矩形的字符区域。
应用于Shape对象的TextFrame 属性返回一个TextFrame对象，该对象包含指定图形对象的对齐和定位属性；Characters方法返回一个Characters对象，该对象代表某个图形的文本框中的字符区域，语法如下：
expression.Characters(Start, Length) 参数expression是必需的，返回一个指定文本框内Characters对象的表达式。
        参数Start是可选的，表示将要返回的第一个字符，如果此参数设置为 1 或被忽略，则Characters方法会返回以第一个字符为起始字符的字符区域。
        参数Length是可选的，表示要返回的字符个数。
如果此参数被忽略，则Characters方法会返回该字符串的剩余部分（由Start参数指定的字符以后的所有字符）。
        第9行代码为矩形添加文字，应用于Characters对象的Text属性返回或设置对象的文本，为可读写的String类型。
        第10行到第15行代码设置矩形中文字的属性，应用于Characters对象Font属性返回一个Font对象，该对象代表指定对象的字体属性（字体名称、字体大小、字体颜色等），第11行代码设置字体名称，第12行代码设置字体样式，第13行代码设置字体大小，第14行代码颜色。
        第17行到第20行代码设定矩形中文字的对齐方式。
应用于TextFrame对象的HorizontalAlignment属性返回或设置指定对象的水平对齐方式，可为表格所示的XlHAlign常量之一。

       应用于TextFrame对象的VerticalAlignment属性返回或设置指定对象的垂直对齐方式，可为表格所示的XlHAlign常量之一。

       第21行代码设置矩形大小和位置不随单元格而变，应用于Shape对象的Placement属性返回或设置对象与所在的单元格之间的附属关系，可为表格所示的XlPlacement常量之一。

       第24行到第32行代码设置矩形的边框线条格式，应用于ShapeRange集合的Line属性返回一个LineFormat 对象，该对象包含指定图形的线条格式属性。
        其中第26行代码设置矩形线条粗细，第27行代码设置矩形线条的虚线样式，第28行代码设置矩形填充的透明度，第29行代码设置矩形为可见，第30行代码设置矩形的前景色，第31行代码设置矩形填充背景的颜色。
        第33行到第38行代码设置矩形的内部填充格式，应用于ShapeRange集合的Fill属性返回FillFormat对象，该对象包含指定的图表或图形的填充格式属性。
        其中第35行代码设置矩形内部的透明度，第36行代码设置矩形内部为可见，第37行代码设置矩形内部的前景色，第38行代码将矩形内部指定填充设为单色渐变，应用于 FillFormat对象的OneColorGradient方法将指定填充设为单色渐变，语法如下：
expression.OneColorGradient(Style, Variant, Degree) 其中参数Style是必需的，底纹样式，可为表格所示的MsoGradientStyle常量之一。

       参数Variant是必需的，渐变变量。
取值范围为 1 到 4 之间，分别与“填充效果”对话框中“渐变”选项卡的四个渐变变量相对应。
如果GradientStyle 设为 msoGradientFromCenter，则Variant参数只能设为 1 或 2。
        参数Degree是必需的，灰度。
取值范围为 0.0（表示最深）到 1.0（表示最浅）之间。
        第42、43行代码为矩形对象添加超链接，应用于Hyperlinks对象的Add方法向指定的区域或图形添加超链接，语法如下：
expression.Add(Anchor, Address, SubAddress, ScreenTip, TextToDisplay) 参数expression是必需的，返回一个Hyperlinks对象。
        参数Anchor是必需的，超链接的位置。
可为Range对象或Shape对象。
        参数Address是必需的，超链接的地址。
        参数SubAddress是必需的，超链接的子地址。
        参数ScreenTip是可选的，当鼠标指针停留在超链接上时所显示的屏幕提示。
        参数TextToDisplay是可选的，要显示的超链接的文本。
        运行AddShape过程结果如图所示。

 

1

吃撑De三文鱼
第4部分 Shape（图形）、Chart（图表）对象
技巧54 导出工作表中的图片 使用Export方法将工作表中的图片以文件形式导出，如下面的代码所示。

  Sub ExportShp()
      Dim Shp As Shape
      Dim FileName As String
      For Each Shp In Sheet1.Shapes
          If Shp.Type = msoPicture Then
              FileName = ThisWorkbook.Path & "" & Shp.Name & ".gif"
              Shp.Copy
              With Sheet1.ChartObjects.Add(0, 0, Shp.Width + 28, Shp.Height + 30).Chart
                  .Paste
                  .Export FileName, "gif"
                  .Parent.Delete
              End With
          End If
      Next
  End Sub
       ExportShp过程将Sheet1工作表的所有图片以文件形式导出到同一目录中。
        第4行代码使用For Each...Next 语句遍历Sheet1工作表中的所有图形。
        第5行代码判断图形的类型是否为图片，应用于Shape对象的Type属性返回或设置图形类型，可以为表格所示的MsoShapeType常量之一。

       第6行代码使用字符串变量FileName记录需导出图形的路径和名称。
        第7行代码复制图形，应用于Shape对象的Copy方法将对象复制到剪贴板。
        第8行代码使用Add方法在工作表中添加一个图表，应用于ChartObjects对象的Add 方法创建新的嵌入图表，语法如下：
expression.Add(Left, Top, Width, Height) 参数expression是必需的，返回一个ChartObjects对象。
        参数Left、参数Top是必需的，以磅为单位给出新对象的初始坐标，该坐标是相对于工作表上单元格A1的左上角或图表的左上角的坐标。
        参数Width、参数Height是必需的，以磅为单位给出新对象的初始大小。
        第9行代码使用Paste方法将图形粘贴到新的嵌入图表中，应用于Chart对象的Paste方法将剪贴板中的图表数据粘贴到指定的图表中，语法如下：
expression.Paste(Type) 参数expression是必需的，返回一个Chart对象。
        参数Type是可选的的，如果剪贴板中有图表，本参数指定要粘贴的图表信息。
可为以下XlPasteType常量之一：xlFormats、xlFormulas或xlAll。
默认值为xlAll，如果剪贴板中是数据不是图表，则不能使用本参数。
        第10行代码使用Export方法将图表导出到同一目录中，应用于Chart对象的Export方法以图形格式导出图表，语法如下：
expression.Export(Filename, FilterName, Interactive) 其中参数Filename是必需的，被导出的文件的名称。
        第10行代码删除新建的图表。
因为Chart对象是不能使用Delete方法直接删除的，应先使用Parent属性返回指定对象的父对象，然后使用Delete方法删除。

 

1

鄂龙蒙
原代码无任何保护作用，因为SelectionChange触发，就会解除工作表保护，思路有问题。
 Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next If Sheet1.Protection = False ...
我不知你有没有没测试过，不错，第二句代码是解除了工作表的保护，但此技巧是保护工作表中已录入数据的单元格，只要不是空白单元格，下面还有保护工作表的代码，怎么无任何保护作用了？
https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=11
第4部分 Shape（图形）、Chart（图表）对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧55 在工作表中添加艺术字 在工作表中插入艺术字，可以使用AddTextEffect方法，如下面的代码所示。

  Sub TextEffect()
      Dim myShape As Shape
      On Error Resume Next
      Sheet1.Shapes("myShape").Delete
      Set myShape = Sheet1.Shapes.AddTextEffect _
              (PresetTextEffect:=msoTextEffect15, _
              Text:="我爱 Excel Home", FontName:="宋体", FontSize:=36, _
              FontBold:=msoFalse, FontItalic:=msoFalse, _
              Left:=100, Top:=100)
      With myShape
          .Name = "myShape"
          With .Fill
              .Solid
              .ForeColor.SchemeColor = 55
              .Transparency = 0
          End With
          With .Line
              .Weight = 1.5
              .DashStyle = msoLineSolid
              .Style = msoLineSingle
              .Transparency = 0
              .ForeColor.SchemeColor = 12
              .BackColor.RGB = RGB(255, 255, 255)
          End With
      End With
      Set myShape = Nothing
  End Sub
       TextEffect过程在工作表中插入艺术字并设置其格式。
        第3、4行代码删除工作表中可能存在的艺术字，以免重复添加。
        第5行到第9行代码使用AddTextEffect方法在工作表中插入艺术字，AddTextEffect方法创建艺术字对象。
返回一个Shape对象，该对象代表新建的艺术字对象，语法如下：
expression.AddTextEffect(PresetTextEffect, Text, FontName, FontSize, FontBold, FontItalic, Left, Top) 参数expression是必需的，返回一个Shapes对象。
        参数PresetTextEffect是必需的，艺术字预置文本效果，可为MsoPresetTextEffect 常量之一，等同于在工作表中插入艺术字时的样式选项卡，如图所示。

       参数Text是必需的，艺术字对象中的文字。
        参数FontName是必需的，艺术字对象中所用的字体名称。
        参数FontSize是必需的，以磅为单位给出艺术字对象中所用的字体大小。
        参数FontBold是必需的，在艺术字中要加粗的字体。
        参数FontItalic是必需的，在艺术字中要倾斜的字体。
        参数Left和参数Top是必需的，相对于文档的左上角、顶部，以磅为单位给出艺术字对象边框左上角的位置。
        第11行代码将艺术字对象重命名为“myShape”。
        第12行到第16行代码设置艺术字对象的填充格式。
其中第13行代码将填充格式设置为均一的颜色，应用于FillFormat 对象的Solid方法将指定的填充格式设置为均一的颜色，可用本方法将带有渐进色、纹理、图案或背景的填充格式转换为单色的填充格式。
第14行代码设置填充的颜色。
第15行代码设置填充的透明度。
        第17行到第24行代码设置艺术字对象的线条格式属性。
其中第18行代码设置线条粗细，第19行代码设置线条虚线样式，第20行代码设置线条区域的样式，第21行代码设置线条的透明度，第22行代码设置前景色，第23行代码设置填充背景的颜色。
        运行TextEffect过程工作表中如图所示。

第4部分 Shape（图形）、Chart（图表）对象
技巧56 遍历工作表中的图形 工作表中的多个图形，如果使用系统缺省名称，如“文本框1”、“文本框2”这样前面是固定的字符串，后面是序号的，可以使用For...Next 语句遍历图形，如下面的代码所示。

  Sub ErgShapes_1()
      Dim i As Integer
      For i = 1 To 4
          Sheet1.Shapes("文本框 " & i).TextFrame.Characters.Text = ""
      Next
  End Sub
       ErgShapes_1过程清除工作表中四个图形文本框中的文字。
        第3行到第5行代码，使用Shapes属性在工作表上的三个图形文本框中循环。
        Shapes属性返回Shapes对象，代表工作表或图形工作表上的所有图形，可以使用Shapes（index）返回单个的Shape对象，其中index是图形的名称或索引号。
        返回单个的Shape对象后使用TextFrame 属性和Characters方法清除文本框中的字符，关于Shape对象的TextFrame 属性和Characters方法请参阅技巧53 。
        如果图形的名称没有规律，可以使用For Each...Next 语句循环遍历所有图形，根据Type属性返回的图形类型进行相应的操作，如下面的代码所示。

  Sub ErgShapes_2()
      Dim myShape As Shape
      Dim i As Integer
      i = 1
      For Each myShape In Sheet1.Shapes
          If myShape.Type = msoTextBox Then
              myShape.TextFrame.Characters.Text = "这是第" & i & "个文本框"
              i = i + 1
          End If
      Next
  End Sub
       ErgShapes_2过程在工作表中的所有图形文本框中写入文本。
        第5行代码使用For Each...Next 语句循环遍历工作表中所有的图形对象。
        第6行到第9行代码如果图形对象是文本框则在文本框中写入文本。
其中第6行代码根据Type属性判断图形对象是否为文本框，应用于Shape对象的Type属性返回或设置图形类型，MsoShapeType类型，如表格所示。

       第7行代码根据返回的Type属性值在所有的文本框内写入相应的文本，如图所示。

 

1

征婚启事
第4部分 Shape（图形）、Chart（图表）对象
技巧57 移动、旋转图片 工作表中的图片可以移动、旋转，如下面的代码所示。

  Sub MoveShape()
      Dim i As Long
      Dim j As Long
      With Sheet1.Shapes(1)
          For i = 1 To 3000 Step 5
             .Top = Sin(i * (3.1416 / 180)) * 100 + 100
             .Left = Cos(i * (3.1416 / 180)) * 100 + 100
             .Fill.ForeColor.RGB = i * 100
              For j = 1 To 10
                  .IncrementRotation -2
                  DoEvents
              Next
          Next
      End With
  End Sub
       MoveShape过程移动、旋转工作表中的图片并不断改变其填充的前景色。
        第6行代码设置图片的Top属性值，应用于Shape对象的Top属性设置图形的顶端到工作表顶端的距离。
在循环的过程中使用Sin函数将Top属性值设置为一个圆形的弧度值。
Sin函数返回指定参数的正弦值，语法如下：
Sin(number) 参数number表示一个以弧度为单位的角。
        Sin函数取一角度为参数值，并返回角的对边长度除以斜边长度的比值，将角度除以180后即能角度转换为弧度。
        第7行代码设置图片的Left属性值，应用于Shape对象的Left属性设置图形从左边界至 A 列左边界（在工作表中）或图表区左边界（在图表工作表中）的距离。
在循环的过程中使用Cos函数将Left属性值设置为一个圆形的弧度值。
Cos函数返回指定一个角的余弦值，语法如下：
Cos(number) 参数number表示一个以弧度为单位的角。
        Cos函数的number参数为一个角，并返回直角三角形两边的比值，该比值为角的邻边长度除以斜边长度之商，将角度除以180后即能角度转换为弧度。
        第8行代码设置图片填充的前景色随着循环的过程不断的变化。
使用Fill属性返回一个FillFormat对象，FillFormat对象代表图形的填充格式，其ForeColor 属性设置对象填充的前景色。
        第9行到第11行代码在图形移动的过程中使用IncrementRotation方法设置图形绕 z 轴的转角，IncrementRotation方法以指定的度数为增量，更改指定的图形绕 z 轴的转角，语法如下：
expression.IncrementRotation(Increment) 参数expression是必需的，返回一个Shape对象。
        参数Increment是必需的，以度为单位指定图形在水平方向的旋转量，正值使图形按顺时针方向旋转，负值使图形按逆时针方向旋转。
        其中第11行是关键的代码，使用DoEvents函数转让控制权，否则达不到预计的视觉效果。
        运行MoveShape过程，工作表的图形在自身进行逆时针方向旋转的同时沿着一个圆形的弧度进行移动，并不断改变其填充的颜色。

 

1

征婚启事
第4部分 Shape（图形）、Chart（图表）对象
技巧58 工作表中自动插入图片 在日常工作中经常需要在工作表中插入大量图片，比如在如图所示的工作表中需要根据A列的名称在C列插入保存在同一目录中的相应的图片，如果使用手工插入不仅非常繁琐且极易出错，而使用VBA代码可以很好的完成操作。

       示例代码如下：
  Sub insertPic()
      Dim i As Integer
      Dim FilPath As String
      Dim rng As Range
      Dim s As String
      With Sheet1
          For i = 3 To .Range("a65536").End(xlUp).Row
              FilPath = ThisWorkbook.Path & "" & .Cells(i, 1).Text & ".jpg"
              If Dir(FilPath) <> "" Then
                  .Pictures.Insert(FilPath).Select
                  Set rng = .Cells(i, 3)
                  With Selection
                      .Top = rng.Top + 1
                      .Left = rng.Left + 1
                      .Width = rng.Width - 1
                      .Height = rng.Height - 1
                  End With
              Else
                  s = s & Chr(10) & .Cells(i, 1).Text
              End If
          Next
          .Cells(3, 1).Select
      End With
      If s <> "" Then
          MsgBox s & Chr(10) & "没有照片!"
      End If
  End Sub
       insertPic过程使用Insert方法在工作表中插入图片。
        第7行代码开始For...Next循环，循环的终值由工作表中A列单元格的行数所决定。
        第8行代码字符串变量FilPath保存A列名称单元格所对应的图片文件的路径和文件名，本例中图片文件的文件名应和A列中的名称一致。
        第9行到第11行代码使用Dir函数在同一文件夹中查找与A列单元格中的名称相对应的图片文件，如果对应的图片文件存在则使用Insert方法将图片插入到工作表中，并将C列的单元格赋给变量rng。
        Dir函数返回一个String，用以表示一个文件名、目录名或文件夹名称，它必须与指定的模式或文件属性、或磁盘卷标相匹配。
如果已没有合乎条件的文件，则Dir函数会返回一个零长度字符串 ("")。
        第12行到第17行代码，当图片片插入到工作表时其实是插入到活动单元格的，此时需设置图片的Top属性和Left属性将图片移动到C列所对应的单元格中，并设置其Width属性和Height属性使其适应所在单元格的大小。
        第18、19行代码如果在同一文件夹中没有与A列单元格对应的图片文件，则使用字符串变量s保存没有图片文件的名称。
        第24行到第26行代码如果字符串变量s不等于空白说明文件夹中缺少图片文件，使用消息框提示。
        运行insertPic过程工作表如图所示。

       如果文件夹中缺少对应的图片文件，则会进行提示，如图所示。

 

1

征婚启事
第4部分 Shape（图形）、Chart（图表）对象
技巧59 固定工作表中图形的位置 工作表中插入的图片，一般都是固定的尺寸和固定的单元格区域中的，但在实际使用中可能因一些人为的因素导致图片位置偏移或尺寸变化，此时可以使用VBA代码进行调整，如下面的代码所示。

  Sub ShapeAddress()
      Dim rng As Range
      Set rng = Sheet1.Range("B4:E22")
      With Sheet1.Shapes("Picture 1")
          .Rotation = 0
          .Select
          With Selection
              .Top = rng(1).Top + 1
              .Left = rng(1).Left + 1
              .Width = rng.Width - 0.5
              .Height = rng.Height - 0.5
          End With
      End With
      Range("A1").Select
  End Sub
       ShapeAddress过程调整指定图形在工作表中的位置。
        第3行代码变量rng保存工作表中插入图片的单元格区域。
。
        第5行代码设置图片的转角，应用于Shape对象Rotation属性以度为单位返回或设置图形的转角，设置为正值向右偏转，设置为负值向左偏转，设置为零图片则保持90度垂直。
        第7行到第12行代码设置图片的Top属性和Left属性将图片移动变量rng所保存的单元格区域中，并设置其Width属性和Height属性使其适应所在单元格区域的大小。
        第14行代码选择A1单元格，不然图片处于选中状态。
        经过以上设置，工作表中的图片“Picture 1”不管处于什么状态都可以一键恢复其原来的大小、位置。

请问33楼中 Not Rng Is Nothing 和Loop While Not Rng Is Nothing 这是什么意思呢，不是特别明白，以后能否解析的详细些，毕竟有些是新手，谢谢
Not Rng Is Nothing 应用于Range 对象的Find 方法在区域中查找特定信息，如果未发现匹配单元格，就返回Nothing，而Not运算符用来对表达式进行逻辑否定运算，Not Rng Is Nothing 就是说找到匹配单元格。

Loop While Not Rng Is Nothing 整句代码应该是Loop While Not rng Is Nothing And rng.Address <> FindAddress Do...Loop 语句的结束条件，意思就是找到匹配单元格并且和第一次找到的匹配单元格的地址一样时结束Do...Loop 循环，否则一直查找下去。

如果你选择单元格，然后按delete键的话还是会出现保护的按钮！望解答～
这只是工作表的双击事件，只能屏蔽双击时出现的对话框。

太有实用价值，听大师在讲课，惟有诚惶诚恐，不敢高声语。

不敢说是讲课，只是一些学习心得与大家分享，谬误之处还请大家指正.
非常不错 ，不过想知道楼主是怎么知道这么多的， 本人学习vba 靠的是 录制新的宏 录制完毕之后看代码 然后学习的， 方法简单快捷，但内容不是很具体， 楼主好像知道 很多参数啊，教一下抓鱼的方法啊
录制宏不失为一种学习VBA的好方法，从录制的宏代码中可以学习到对象的一些方法、属性等，不过录制的宏代码有许多是多余的，使用时要注意删除、修改。
其实学习VBA最好的老师就是Excel VBA中自带的帮助，对于一些不了解的方法、属性，将光标插入后按F1即能显示帮助。

第4部分 Shape（图形）、Chart（图表）对象
技巧60 使用VBA自动生成图表 在实际工作中我们常用图表来表现数据间的某种相对关系，一般采用手工插入的方式，而使用VBA代码可以在工作表中自动生成图表，如下面的示例代码。

  Sub ChartAdd()
      Dim myRange As Range
      Dim myChart As ChartObject
      Dim R As Integer
      With Sheet1
          .ChartObjects.Delete
          R = .Range("A65536").End(xlUp).Row
          Set myRange = .Range("A" & 1 & ":B" & R)
          Set myChart = .ChartObjects.Add(120, 40, 400, 250)
          With myChart.Chart
              .ChartType = xlColumnClustered
              .SetSourceData Source:=myRange, PlotBy:=xlColumns
              .ApplyDataLabels ShowValue:=True
              .HasTitle = True
              .ChartTitle.Text = "图表制作示例"
              With .ChartTitle.Font
                  .Size = 20
                  .ColorIndex = 3
                  .Name = "华文新魏"
              End With
              With .ChartArea.Interior
                  .ColorIndex = 8
                  .PatternColorIndex = 1
                  .Pattern = xlSolid
              End With
              With .PlotArea.Interior
                  .ColorIndex = 35
                  .PatternColorIndex = 1
                  .Pattern = xlSolid
              End With
              .SeriesCollection(1).DataLabels.Delete
              With .SeriesCollection(2).DataLabels.Font
                  .Size = 10
                  .ColorIndex = 5
              End With
          End With
      End With
      Set myRange = Nothing
      Set myChart = Nothing
  End Sub
       ChartAdd过程在工作表中自动生成图表，图表类型为簇状柱形图。
        第6行代码使用Delete方法删除工作表中已经存在的图表，而ChartObjects方法返回代表工作表中单个嵌入图表（ChartObject对象）或所有嵌入图表的集合（ChartObjects对象）的对象，语法如下：
expression.ChartObjects(Index) 其中参数Index是可选的，指定图表的名称或号码。
该参数可以是数组，用于指定多个图表，因为示例中只有一个图表，所以无需指定其Index参数。
        第8行代码指定图表的数据源。
         第9行代码使用Add方法创建一个新图表，应用于ChartObjects对象的Add方法创建新的嵌入图表，语法如下：
expression.Add(Left, Top, Width, Height) 参数Left、Top是必需的，以磅为单位给出新对象的初始坐标，该坐标是相对于工作表上单元格A1的左上角或图表的左上角的坐标。
        参数Width、Height是必需，以磅为单位给出新对象的初始大小。
        第10行代码使用Chart属性返回新创建的图表，应用于ChartObject对象的Chart属性返回一个Chart对象，该对象代表指定对象所包含的图表。
        第11行代码指定新创建图表的图表类型，应用于Chart对象的ChartType属性返回或设置图表的类型，可以为XlChartType常量之一，具体请参阅VBA帮助。
本例中设置为xlColumnClustered即图表类型为簇状柱形图。
        第12行代码指定图表的数据源和绘图方式，应用于Chart对象的SetSourceData方法为指定图表设置源数据区域，语法如下：
expression.SetSourceData(Source, PlotBy) 参数expression是必需的，该表达式返回一个Chart对象。
        参数Source是可选的，源数据的区域。
        参数PlotBy是可选的，指定数据绘制方式，可为xlColumns（系列产生在列）或xlRows（系列产生在行）。
        第13行代码使用ApplyDataLabels方法使图表显示数据标签和数据点的值，应用于Chart对象的ApplyDataLabels方法将数据标签应用于图表中的某一数据点、某一数据系列或所有数据系列，语法如下：
expression.ApplyDataLabels(Type, LegendKey, AutoText, HasLeaderLines, ShowSeriesName, ShowCategoryName, ShowValue, ShowPercentage, ShowBubbleSize, Separator) 参数expression是必需的，该表达式返回一个Chart对象。
        参数Type是可选的，要应用的数据标签的类型，可为表格所列的XlDataLabelsType 常量之一。

       参数LegendKey是可选的，如果该值为True，则显示数据点旁的图例项标示。
默认值为False。
        参数AutoText是可选的，如果对象根据内容自动生成正确的文字，则该值为True。
        参数HasLeaderLines是可选的，如果数据系列具有引导线，则该值为True。
        参数ShowSeriesName是可选的，数据标签的系列名称。
        参数ShowCategoryName是可选的，数据标签的分类名称。
        参数ShowValue是可选的，数据标签的值。
        参数ShowPercentage是可选的，数据标签的百分比。
        参数ShowBubbleSize是可选的，数据标签的气泡尺寸。
        参数Separator是可选的，数据标签的分隔符。
        第14、15行代码设置新创建的图表有可见的标题并设置图表标题的文字。
应用于Chart对象的HasTitle属性，如果坐标轴或图表有可见标题，则该值为True，而ChartTitle属性返回一个ChartTitle对象，代表指定图表的标题。
        第16行到第20行代码设置图表标题文字的格式。
        第21行到第25行代码设置图表区的颜色。
        第26行到第30行代码设置绘图区的颜色。
        第31行代码删除图表上第一个数据系列中的数据标签。
SeriesCollection方法返回图表或图表组中单个数据系列（Series对象)或所有数据系列的集合（SeriesCollection集合)的对象，语法如下：
expression.SeriesCollection(Index) 可选的Index参数指定数据系列的名称或编号。
        而DataLabels方法则返回代表数据系列中的单个数据标签（DataLabel对象）或所有数据标签的集合（DataLabels集合）的对象，语法如下：
expression.DataLabels(Index) 可选的Index参数指定数据系列中的数据标签的编号。
        第32行到第36行代码设置图表上第二个数据系列中的数据标签的字体格式。
        运行ChartAdd过程，在工作表中创建簇状柱形图，如图所示。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=12
本帖已被收录到知识树中，索引项：开发帮助和教程
如果我想把图片放在统一的“图片库”子文件中，请问如何编宏？或我想放在"D\水泵图片" 固定的文件夹下，如何编辑宏的代码？谢谢您的指导，期待您的答案 Sub insertPic() Dim i As Integer Dim FilPath As String Dim rng As Range Dim s As String With Sheet1 For i = 3 To .Range("a65536").End(xlUp).Row FilPath = "D:\水泵图片" & .Cells(i, 1).Text & ".jpg" If Dir(FilPath) <> "" Then .Pictures.Insert(FilPath).Select Set rng = .Cells(i, 3) With Selection .Top = rng.Top + 1 .Left = rng.Left + 1 .Width = rng.Width - 1 .Height = rng.Height - 1 End With Else s = s & Chr(10) & .Cells(i, 1).Text End If Next .Cells(3, 1).Select End With If s <> "" Then MsgBox s & Chr(10) & "没有照片!" End If End Sub

第4部分 Shape（图形）、Chart（图表）对象
技巧61 使用独立窗口显示图表 如果需要将工作表中嵌入的图表显示在独立的窗口中，可以使用下面的代码。

  Sub ChartShow()
      With Sheet1.ChartObjects(1)
          .Activate
          .Chart.ShowWindow = True
      End With
      With ActiveWindow
          .Top = 50
          .Left = 50
          .Width = 400
          .Height = 280
          .Caption = ThisWorkbook.Name
      End With
  End Sub
       ChartShow过程，将工作表中嵌入的图表显示在独立的窗口中。
        第2行到第5行代码将工作表中指定图表的ShowWindow属性设置为True，使用独立的窗口显示该图表。
        第7、8行代码指定活动窗口显示的位置。
        第9、10行代码调整活动窗口的大小使之适应图表的大小。
        第11行代码指定活动窗口标题栏中显示的标题。
        运行ChartShow过程结果如图所示。

版主，第四部分什么时候能打包下载？
快了，因为图形与图表平时用的不多，所以需要整理的技巧不是太多，估计明后天就能完成了。

第4部分 Shape（图形）、Chart（图表）对象
技巧62 导出工作表中的图表 如果需要将工作表中的图表保存为单独的图像文件，可以使用Export方法以图形文件格式导出图表，示例代码如下。

#Chart

  Sub ExportChart()
      Dim myChart As Chart
      Dim myFileName As String
      Set myChart = Sheet1.ChartObjects(1).Chart
      myFileName = "myChart.jpg"
      On Error Resume Next
      Kill ThisWorkbook.Path & "" & myFileName
      myChart.Export Filename:=ThisWorkbook.Path _
          & "" & myFileName, Filtername:="JPG"
      MsgBox "图表已保存在[" & ThisWorkbook.Path & "]文件夹中!"
      Set myChart = Nothing
  End Sub
       ExportChart过程使用Export方法将工作表中的图表以图形文件的形式导出。
        第4行代码指定工作表中的图表对象。
        第5行代码指定图形文件保存的文件名。
        第6、7行代码使用Kill语句删除文件夹中原有的图形文件。
当文件夹中指定删除的文件不存在时Kill语句会出错所以需要使用On Error语句忽略错误。
        第8、9行代码使用Export方法将图表导出到同一目录中，应用于Chart对象的Export方法以图形文件格式导出图表，语法如下：
expression.Export(Filename, FilterName, Interactive) 其中参数Filename是必需的，被导出的文件的名称，示例中加上了文件保存的路径。
      参数FilterName是可选的，被导出的文件的图形格式，示例中文件以JPG文件格式保存。

第4部分 Shape（图形）、Chart（图表）对象
技巧63 多图表制作 如果需要，我们可以为工作表中的每一个数据区域创建一张图表，在如图所示的工作表区域中，需要为每一个员工的全年数据创建一张图表。

       示例代码如下：
  Sub ChartsAdd()
      Dim myChart As ChartObject
      Dim i As Integer
      Dim R As Integer
      Dim m As Integer
      R = Sheet1.Range("A65536").End(xlUp).Row - 1
      m = Abs(Int(-(R / 4)))
      Sheet2.ChartObjects.Delete
      For i = 1 To R
          Set myChart = Sheet2.ChartObjects.Add _
              (Left:=(((i - 1) Mod m) + 1) * 350 - 320, _
              Top:=((i - 1) \ m + 1) * 220 - 210, _
              Width:=330, Height:=210)
          With myChart.Chart
              .ChartType = xlColumnClustered
              .SetSourceData Source:=Sheet1.Range("B2:M2").Offset(i - 1), _
              PlotBy:=xlRows
              With .SeriesCollection(1)
                  .XValues = Sheet1.Range("B1:M1")
                  .Name = Sheet1.Range("A2").Offset(i - 1)
                  .ApplyDataLabels AutoText:=True, ShowValue:=True
                  .DataLabels.Font.Size = 10
              End With
              .HasLegend = False
              With .ChartTitle
                  .Left = 5
                  .Top = 1
                  .Font.Size = 14
                  .Font.Name = "华文行楷"
              End With
              With .PlotArea.Interior
                  .ColorIndex = 2
                  .PatternColorIndex = 1
                  .Pattern = xlSolid
              End With
              .Axes(xlCategory).TickLabels.Font.Size = 10
              .Axes(xlValue).TickLabels.Font.Size = 10
          End With
      Next
      Sheet2.Select
      Set myChart = Nothing
  End Sub
       ChartsAdd过程根据数据工作表A列的人数在图表工作表中创建图表并分4行排列整齐。
        第6行代码取得数据工作表中需要创建图表的人数。
        第7行代码计算图表工作表每行需要排列的图表数目，共分4行排列。
使用Int函数返回图表数目除4行后的整数部分，使用负值是为了向上取整数，最后使用Abs函数返回绝对值，将负值转化为正值。
        第8行代码使用Delete方法删除图表工作表中存在的所有图表。
        第9行代码开始For...Next循环，循环的终值由需要创建的图表数目决定。
        第10行到第13行代码使用Add方法在图表工作表中创建嵌入的图表，关于应用于ChartObjects对象的Add方法请参阅技巧60 。
其中第11、12行代码根据循环计数器的数值设置新创建图表的Left和Top属性使之依次排列。
第13行代码设置图表的大小。
        第15行代码设置新创建图表的类型。
        第16、17行代码根据循环计数器的数值分别设置新创建图表的数据源。
        第18行到第23行代码设置图表第一个数据系列的名称、数据标签和字体格式。
        第24行代码删除图表中的图例。
        第25行到第30行代码设置图表的标题。
        第31行到第35行代码设置图表的绘图区。
        第36、37行代码设置图表坐标轴的字体大小。
        关于图表的设置请参阅技巧60 。
        运行ChartsAdd过程图表工作表中如图所示。

第4部分 Shape（图形）、Chart（图表）对象
1-4部分Word文档

第4部分附件

第5部分 Application对象
技巧64 取得Microsoft Excel版本信息 Application对象的Version属性可以返回Microsoft Excel的版本号，如下面的代码所示。

  Sub AppVersion()
      Dim myVersion As String
      Select Case Application.Version
          Case "8.0"
              myVersion = "97"
          Case "9.0"
              myVersion = "2000"
          Case "10.0"
              myVersion = "2002"
          Case "11.0"
              myVersion = "2003"
          Case Else
              myVersion = "版本未知"
      End Select
      MsgBox "Excel 版本是： " & myVersion
  End Sub
       AppVersion过程返回Application对象的Version属性值来取得Microsoft Excel版本号。
        应用于Application对象的Version属性返回Microsoft Excel版本号，语法如下：
expression.Version 参数expression是必需的，Application对象。
        运行AppVersion过程结果如图所示。

第5部分 Application对象
技巧65 取得当前用户名称 使用Application对象的UserName属性可以取得当前用户名称，如下面的代码所示。
Sub UserName() MsgBox "当前用户名是: " & Application.UserName End Sub
       UserName过程使用消息框显示当前用户名称。
        Application对象的UserName属性返回或设置当前用户的名称。
        运行UserName过程效果如图所示。

第5部分 Application对象
技巧66 Excel中的“定时器” Excel VBA并没有提供定时器控件，但是用户可以通过Application对象的OnTime方法实现简单的定时器功能，如下面的代码所示。

  Sub StartTimer()
      Sheet1.Cells(1, 2) = Sheet1.Cells(1, 2) + 1
      Application.OnTime Now + TimeValue("00:00:01"), "StartTimer"
  End Sub
       StartTimer过程，使用Application对象的OnTime方法循环调用StartTimer过程实现每隔一秒钟运行一次StartTimer过程，从而在B1单元格中不断地显示程序累计运行时间，如图所示。

       第2行代码将B1单元格的值在原有的数字上加1。
       第3行代码使用OnTime方法在1秒后重新调用StartTimer过程，使B1单元格的值不断的加1，从而显示程序累计运行时间。
       应用于Application对象的OnTime方法能够安排一个过程在将来的特定时间运行，语法如下：
expression.OnTime(EarliestTime, Procedure, LatestTime, Schedule) 参数expression是必需的，返回一个Application对象。
        参数EarliestTime是必需的，设置指定的过程开始运行的时间。
使用Now + TimeValue(time)可以安排从现在开始经过一段时间之后运行某个过程，使用TimeValue(time)可以安排在指定的时间运行某个过程。
        参数Procedure是必需的，设置要运行的过程名称。
        参数LatestTime是可选的，设置过程开始运行的最晚时间。
例如将参数LatestTime设置为EarliestTime+10，当时间到了EarliestTime时如果Excel不处于空闲状态，那么Excel将等待10秒，如果在10秒内Excel不能回到空闲状态，则不运行该过程。
如果省略该参数，Excel将一直等待到可以运行该过程为止。
        参数Schedule是可选的，如果其值为True（默认值），则安排一个新的OnTime过程，如果其值为False，则清除先前设置的过程。
        取消定时的代码如下：
  Sub EndTimer()
      On Error GoTo Line
      Application.OnTime Now + TimeValue("00:00:01"), "StartTimer", , False
      Sheet1.Cells(1, 2) = 0
      Exit Sub
  Line:
      MsgBox "请先按[开始]按钮!"
  End Sub
       EndTimer过程取消StartTimer过程的定时。
        第2行代码错误处理语句，因为如果还没有运行StartTimer过程而先运行EndTimer过程取消定时，程序会提示错误，如图 所示，因此使用On Error GoTo Line语句在错误发生时执行第7行代码显示一个如图 所示的提示消息框。

关于此示例中定时时间大于一秒的运行错误已由cxmgxl 解决，示例在597楼，http://club.excelhome.net/thread-395683-60-1.html，在此表示感谢。

 

第5部分 Application对象
技巧67 设置活动打印机的名称 使用Application 对象的ActivePrinter属性可以设置活动打印机的名称，如下面的代码所示。

  Sub myPrinter()
      Dim myPrinter As String
      myPrinter = "HP LaserJet P1008 在 Ne04:"
      Application.ActivePrinter = myPrinter
      MsgBox "活动打印机为：" & Left(myPrinter, InStr(myPrinter, "在") - 1)
  End Sub
       myPrinter过程将活动打印机设置为“HP LaserJet P1008”。
        第3行代码指定需要设置为活动打印机的名称，第4行代码通过设置Application 对象的ActivePrinter属性将活动打印机设置为“HP LaserJet P1008”。
        第5行代码使用消息框显示活动打印机的名称及型号。
        运行myPrinter过程结果如图所示。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=13
第5部分 Application对象
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧68 屏蔽、改变组合键的功能 使用Application 对象的OnKey方法可以屏蔽或改变组合键的默认操作，如下面的代码所示。

  Private Sub Workbook_Open()
      Application.OnKey "^{c}", "myOnKey"
  End Sub
  Sub myOnKey()
      MsgBox "本工作表禁止复制数据!"
  End Sub
       第1行到第3行代码工作簿的Open事件，在工作簿打开时使用OnKey方法改变<Ctrl +C>组合键的功能。
        应用于Application 对象的OnKey方法指定特定键或特定的组合键运行的过程，语法如下：
expression.OnKey(Key, Procedure) 参数expression是必需的，该表达式返回一个Application 对象。
        参数Key是必需的，用于表示要按的键的字符串，具体请参阅VBA中的帮助。
        参数Procedure是可选的，表示要运行的过程名称的字符串，本示例中将过程名称指定为第4行到第6行代码的“myOnKey”过程，当按下<Ctrl +C>组合键时并不会执行复制操作而只显示一个消息框。
如果将Procedure参数指定为空文本（""），则按<Ctrl +C>组合键时不发生任何操作，达到屏蔽组合键的效果。
        如果省略Procedure参数，则按下<Ctrl +C>组合键时产生Microsoft Excel中的正常结果，同时清除先前使用OnKey方法所做的特殊击键设置，所以恢复<Ctrl +C>组合键的代码如下：
Application.OnKey "^{c}" 为了不影响其他工作簿的功能，恢复代码就放在工作簿的Deactivate事件中，如下面的代码所示：Private Sub Workbook_Deactivate() Application.OnKey "^{c}" End Sub
       当工作簿从活动状态转为非活动状态时恢复<Ctrl +C>组合键的正常功能。

 

1

征婚启事
第5部分 Application对象
技巧69 设置Excel窗口标题栏 Excel主窗口标题栏默认的名称是“Microsoft Excel”，通过设置Application对象的Caption属性可以改变Excel主窗口的标题栏，如下面的代码所示。

  Sub AppCaption()
      Application.Caption = "修改标题栏名称"
      MsgBox "下面将恢复默认的标题栏名称!"
      Application.Caption = Empty
  End Sub
       第2行代码将Excel窗口标题设置为“修改标题栏名称”，如图所示。

       应用于Application对象的Caption属性设置显示在Microsoft Excel主窗口标题栏中的名称，语法如下：
expression.Caption 第3行代码恢复Microsoft Excel主窗口标题栏中的名称。
如果未设置Caption属性（""）或将其设置为Empty（表示未初始化的变量值），则本属性返回“Microsoft Excel”。
        将Caption属性设置为常数vbNullChar（表示值为 0 的字符）可以删除标题栏中的名称，如下面的代码所示。

  Sub DleCaption()
      Application.Caption = vbNullChar
      MsgBox "下面将恢复默认的标题栏名称!"
      Application.Caption =""
  End Sub
       第2行代码删除Excel主窗口标题栏，结果如图所示。

 

第5部分 Application对象
技巧70 自定义Excel状态栏 Excel状态栏显示应用程序的当前状态（例如就绪、输入等）或上下文提示信息，通过设置Application对象的Statusbar属性可以修改状态栏，以显示用户自定义的信息，代码如下：
  Sub myStatusBar()
      Dim rng As Range
      For Each rng In Sheet1.Range("A1:D10000")
          Application.StatusBar = "正在计算单元格 " & rng.Address(0, 0) & " 的数据..."
          rng = 100
      Next
      Application.StatusBar = False
  End Sub
       myStatusBar过程在给选定单元格区域赋值的同时，将Excel状态栏中的文字设置为正在赋值的单元格地址。
        应用于Application对象的StatusBar属性返回或设置状态栏中的文字，如果需要恢复默认的状态栏文字，将本属性设为False即可。
        运行myStatusBar过程Excel状态栏如图所示。

楼主给个综合的下载包吧。

综合的目前暂时不能提供，已完成部分的去2楼找。

第5部分 Application对象
技巧71 灵活退出Excel 在使用Close方法关闭工作簿时，既使当前只有一个打开的工作簿，也只能关闭工作簿而不能关闭Excel程序，而使用Application对象的Quit方法则会关闭所有打开的工作簿，下面的代码可以做到两者兼顾。

  Sub myQuit()
      If Workbooks.Count > 1 Then
          ThisWorkbook.Close
      Else
          Application.Quit
      End If
  End Sub
       myQuit过程在关闭Excel程序时根据当前打开的工作簿数量决定采用何种方法关闭工作簿。
        第2行代码使用Workbook集合的Count属性判断当前打开的工作簿文件数量。
        第3行代码如当前打开两个或两个以上工作簿，使用Close方法关闭代码所在的工作簿。
关于Close方法请参阅技巧45-1。
        第5行代码如果当前只有一个打开的工作簿文件则使用Quit方法关闭Excel程序。
应用于Application对象的Quit方法退出Excel程序，语法如下：
expression.Quit 参数expression是必需的，返回一个Application对象。
        使用Quit方法关闭Excel程序时，如果有未保存的工作簿处于打开状态，则将弹出一个询问是否要保存所作更改的对话框，为避免对话框出现，可在使用Quit方法前保存所有的工作簿，或者将Application对象的DisplayAlerts属性设置为False，在退出Excel程序时，即使有未保存的工作簿，也不会显示对话框，而且不保存就退出。
        如果一个工作簿的Saved属性值为True，但是并没有将工作簿保存到磁盘上，则Excel程序在退出时不会提示保存该工作簿。

第5部分 Application对象
技巧72 隐藏Excel主窗口 如果希望在程序启动时或运行过程中隐藏Excel主窗口，有以下几种实现方法。

72-1 设置Application对象的Visible属性

当Application对象的Visible属性设置为False时，Application对象不可见，即能隐藏Excel主窗口，如下面的代码所示。

  Private Sub Workbook_Open()
      Application.Visible = False
      UserForm1.Show
  End Sub
       代码工作簿的Open事件，在工作簿打开时将Application对象的Visible属性设置为False隐藏Excel主窗口。
        显示Excel主窗口的方法是将Application对象的Visible属性重新设置为True。
        当工作簿文件打开时，隐藏Excel主窗口，只显示用户登录窗体，如图所示。

72-2 将窗口移出屏幕

设置Application对象的Left属性（从屏幕左边界至Microsoft Excel主窗口左边界的距离）和/或Top属性（从屏幕顶端到Microsoft Excel主窗口顶端的距离）将Application对象移出屏幕外，实现隐藏Excel主窗口，如下面的代码所示。

  Private Sub Workbook_Open()
      Application.WindowState = xlNormal
      Application.Left = 10000
      UserForm1.StartUpPosition = 2
      UserForm1.Show
  End Sub
       工作簿的Open事件过程，设置Application对象的Left属性为一个大的数值，从而将应用程序窗口移出屏幕。
        第2行代码将应用程序窗口设置为正常状态，只有当应用程序窗口正常显示时才能够设置Application对象的Left属性。
        第3行代码将Application对象的Left属性设置为一个大的数值，从而隐藏Excel主窗口。
        第4行代码设置用户窗体的StartUpPosition属性值为2，使窗体显示在屏幕的中央。
        重新显示Excel主窗口的方法是将应用程序窗口设置为最大化状态代码如下：
Application.WindowState = xlMaximized 当工作簿文件打开时，隐藏Excel主窗口，只显示用户登录窗体，如图所示，与通过设置Visible属性实现的效果不同，设置Left属性在任务栏中仍然会显示应用程序窗口按钮。

72-3 设置工作簿作为加载宏运行

利用加载宏不显示工作簿窗口的特点，设置工作簿作为加载宏运行来隐藏工作簿窗口，如下面的代码所示。

  Private Sub Workbook_Open()
      ThisWorkbook.IsAddin = True
      UserForm1.Show
  End Sub
       工作簿的Open事件，在工作簿打开时设置其IsAddin属性值为True，指定工作簿作为加载宏运行。
        当工作簿作为加载宏运行时，将有工作薄窗口不可见的特征，从而实现隐藏工作簿窗口的目的，如图所示。

       重新显示Excel主窗口的方法是将工作簿的IsAddin属性值设置为False，以显示工作簿窗口。

第5部分 Application对象
第5部分 Application对象附件

1-5部分Word文档

第6部分 使用对话框
技巧73 使用Msgbox函数

73-1 显示简单的提示信息

在使用Excel的过程中，如果需要向用户显示简单的提示信息，可以使用MsgBox函数显示一个消息框，如下面的代码所示。

  Sub mymsgbox()
      MsgBox "欢迎光临Excel Home!"
  End Sub
       Mymsgbox过程使用MsgBox函数显示一个消息框。
MsgBox函数用于显示提示信息，语法如下：
MsgBox(prompt[, buttons] [, title] [, helpfile, context]) 参数prompt是必需的，代表在消息框中作为信息显示的字符或字符串，最多只能接受约1024个字符，取决于所使用字符的宽度。
        参数buttons是可选的，用于指定消息框中显示按钮的数目及类型、使用的图标样式、缺省按钮以及消息框的强制回应等。
如果省略，则buttons参数的缺省值为0，消息框只显示“确定”按钮。
        参数title是可选的，代表在消息框标题栏中作为标题的字符或字符串。
如果省略，则在标题栏中显示“Microsoft Excel”。
        参数helpfile和参数context是可选的，用来为消息框提供上下文相关帮助的帮助文件和帮助主题。
如果提供了其中一个参数，则必须提供另一个参数，两者缺一不可。
        运行Mymsgbox过程，显示如图所示的消息框。

73-2 定制个性化的消息框

如果希望MsgBox函数显示的消息框具有特定的按钮、图标和标题栏，那么可以使用MsgBox函数的buttons参数和title参数，如下面的代码所示。

  Sub Specialmsbox()
      MsgBox Prompt:="欢迎光临 Excel Home!", _
          Buttons:=vbOKCancel + vbInformation, _
          Title:="Excel Home"
  End Sub
       Specialmsbox过程使用MsgBox函数显示一个具有特定的按钮、图标和标题栏的消息框。
        第3行代码设置消息框的Buttons参数，使消息框显示时具有“确定”、“取消”按钮和信息消息图标。
MsgBox函数的buttons参数设置值如表格所示。

       在设定buttons参数值时，这些值可以相加使用，但每一组中只能选择一个值。
在程序代码中也可以使用buttons参数的常数名称，而不必使用实际数值。
        第4行代码将消息框的Title参数设置为“Excel Home”，使消息框的标题栏显示“Excel Home”。
        运行Specialmsbox过程后，显示一个如图所示的消息框，该消息框具有“Excel Home”标题、信息消息图标和“确定”、“取消”按钮并以“确定”按钮作为默认按钮。

73-3 获得消息框的返回值

如果希望能根据用户对于消息框的不同选择，进行相应的操作，可以对消息框的返回值进行判断，如下面的代码所示。

  Private Sub Workbook_BeforeClose(Cancel As Boolean)
      Dim iMsg As Integer
      iMsg = MsgBox("文件即将关闭,是否保存?", 3 + 32)
      Select Case iMsg
          Case 6
              Me.Save
          Case 7
              Me.Saved = True
          Case 2
              Cancel = True
      End Select
  End Sub
       工作簿的BeforeClose过程，在关闭工作簿前使用MsgBox函数显示一个消息框，并根据用户的回应用进行相应的操作。
        第3行代码，使用MsgBox函数显示一个具有“是”、“否”和“否”按钮的消息框，并把用户的回应，即消息框的返回值赋给变量iMsg。
MsgBox是一个函数，这意味着它将返回一个值，如果希望获得返回值，可使用和第3行相似的代码，此时如果不使用括号将参数封闭起来，则会提示编译错误。
        第4行到第11行代码，Select Case结构语句，根据变量iMsg的值判断用户的回应，如果变量iMsg的值为6，说明用户选择了“是”按钮，则使用Save方法保存工作簿；如果变量iMsg的值为7，说明用户选择了“否”按钮，则将工作簿的Saved属性设置为True，不保存更改而直接关闭工作簿。
关于Save方法和Saved属性请参阅技巧45-2。
如果变量iMsg的值为2，说明用户选择了“取消”按钮，是将BeforeClose过程的Cancel 参数设置为True，取消关闭工作簿操作。
 MsgBox函数的返回值如表格所示，在程序代码中也可以使用常数名称，而不必使用实际数值。

       在关闭本工作簿时将显示一个如图所示的消息框，询问用户是否保存，并根据用户的回应用进行相应的操作。

73-4 在消息框中排版

如果在消息框中显示的字符串很长，比如是一段多行的文字内容，为了达到美观的效果，需要首字缩进，并将各行分隔开来，如下面代码所示。

  Sub Newlinemsbox()
      MsgBox Space(4) & "欢迎来到 ExcelHome 技术论坛，全球最领先的 Excel 技术论坛之一。
" & Chr(10) _
          & Space(4) & "在这里，我们讨论 Microsoft Office 系列产品的应用技术，重点讨论" & Chr(10) _
          & "Microsoft Excel。
" & Chr(10) _
          & Space(4) & "本论坛从属于 Excel Home 这一全球最大的华语 Excel 技术门户，目前" & Chr(10) _
          & "是个人、非营利性质的网站学习平台。
" & Chr(10) _
          & Space(4) & "Let’s do it better! 这是 Excel Home 的口号，我们的宗旨是帮助大" & Chr(10) _
          & "家解决在使用Office软件中的问题，提升自己的应用技能。
"
  End Sub
       Newlinemsbox过程使用消息框显示一段经过排版后的文本内容。
        代码中使用Space 函数在每段的首字前插入4个空格，使首字缩进，在需要换行的地方插入换行符 （Chr(10)） 将各行分隔开来。
也可以使用回车符 （Chr(13)）、或是回车与换行符的组合 （Chr(13) & Chr（10)）换行。
 在程序代码中也可以使用vbCrLf、vbNewLine等常数，而不必使用Chr 函数，如表格 73 3所示。

       运行Newlinemsbox过程, 用消息框显示一段经过排版后的文本内容,效果如图所示。

73-5 对齐消息框中显示的信息

在用消息框显示如图所示的工作表中多行多列的单元格区域时，如果只用换行符（Chr(10)）等进行换行，而数据列没有对齐，会使显示的信息显得杂乱无章，缺乏可读性。

       为了达到消息框中显示信息各列对齐的效果，在使用换行符（Chr(10)）等进行换行的基础上，还需要使用制表符（Chr(9)）或常数vbTab，对数据列进行分隔，使之排列整齐，如下面代码所示。

  Sub Outmsbox()
      Dim sMsg As String
      Dim iRow As Integer
      Dim iCom As Integer
      For iRow = 1 To 11
          For iCom = 1 To 5
              sMsg = sMsg & Cells(iRow, iCom) & Chr(9)
          Next
          sMsg = sMsg & Chr(10)
      Next
      MsgBox sMsg
  End Sub
       Outmsbox过程使用两层循环读取当前工作表中A1到E11单元格的内容，并用消息框显示出来。
        第7行代码，iCom循环中在把逐列读取的单元格内容赋给变量myMsg时插入一个制表符（Chr(9)），对列进行分隔。
        第9行代码，iRow循环中在读取下一行单元格内容赋给变量myMsg时插入一个换行符（Chr(10)），对行进行换行。
        运行Outmsbox过程将用消息框显示当前工作表中A1至E11单元格区域中的内容，并排列整齐，如图所示。

要把链接修改成直奔楼层就好了,如84楼就用:http://club.excelhome.net/redire ... 186&ptid=395683做链接,要求很过份吧.
我也想这样，可是为什么我复制的链接不是到楼层的而只能到页？
第6部分 使用对话框
技巧74 自动关闭的消息框 在程序执行完毕后给用户一个提示信息，但用MsgBox函数显示的消息框将一直保持，需要用户单击“确定”或“关闭”按钮才会关闭。
如果希望显示的消息框自动关闭，那么可以使用以下方法显示消息框。

74-1 使用WshShell

.Popup方法显示消息框
  Sub WshShell()
      Dim WshShell As Object
      Set WshShell = CreateObject("Wscript.Shell")
      WshShell.popup "执行完毕!", 2, "提示", 64
      Set WshShell = Nothing
  End Sub
       WshShell过程使用WshShell.Popup方法显示消息框，2秒后自动关闭。
        WshShell.Popup方法的语法如下：
WshShell.Popup(strText, [natSecondsToWait], [strTitle], [natType]) = intButton 参数strText是必需的，与Msgbox的Prompt参数类似，代表在消息框中作为信息显示的字符或字符串。
如果显示的内容超过一行，可以在每一行之间用换行符 （Chr(10)）等将各行分隔开来。
        参数natSecondsToWait是可选的，其时间单位为妙。
如果提供natSecondsToWait参数且其值大于零，则消息框在natSecondsToWait 参数指定的秒数后关闭。
        参数strTitle是可选的，代表在消息框标题栏中作为标题的字符或字符串，若省略，则窗口标题为“Windows 脚本宿主”。
        参数natType是可选的，指定消息框中显示按钮的数目及类型、使用的图标样式、缺省按钮以及消息框的强制回应等，与MsgBox函数buttons参数相同，请参阅技巧73-2。
        参数intButton指示用户所单击的按扭编号，与MsgBox函数的返回值相同，请参阅技巧73-3。
若用户在natSecondsToWait 秒之前不单击按扭，则返回值为 -1 。
        运行WshShell过程显示一个如图所示消息框，无需点击“确定”按纽，2秒后自动关闭。

74-2 使用API函数显示消息框

使用API函数也可以达到这一效果，如下面的代码所示。

  Public Declare Function SetTimer Lib "user32" ( _
      ByVal hWnd As Long, _
      ByVal nIDEvent As Long, _
      ByVal uElaspe As Long, _
      ByVal lpTimerFunc As Long) As Long
  Public Declare Function KillTimer Lib "user32" ( _
      ByVal hWnd As Long, _
      ByVal nIDEvent As Long) As Long
      Dim TID As Long
  Sub Test()
      TID = SetTimer(0, 0, 2000, AddressOf CloseTest)
      MsgBox "执行完毕!"
  End Sub
  Sub CloseTest(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idevent As Long, _
      ByVal Systime As Long)
      Application.SendKeys "~", True
      KillTimer 0, TID
  End Sub
       第1行代码到第9行代码是API函数声明。
        Test过程显示一个消息框并在3秒钟后运行CloseTest过程。
        CloseTest过程发送一个确定键给Excel程序关闭显示的消息框。
        运行Test过程显示一个如图所示的消息框并在2秒钟后关闭。

PS：由于本人对API函数的知识有限，停留在只能拿来用用的程度，所以以后有类似的API函数不做讲解，对这方面内容感兴趣的朋友请参阅有关的资料。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=14
第6部分 使用对话框
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧75 使用InputBox函数

75-1 简单的数据输入

Excel的使用过程中，有时需要用户输入简单的数据，此时可以使用InputBox函数显示一个对话框，供用户在对话框中输入数据信息，如下面的代码所示。

  Sub myInputBox()
      Dim sInt As String
      Dim r As Integer
      r = Sheet1.Range("A65536").End(xlUp).Row
      sInt = InputBox("请输入人员姓名：")
      If Len(Trim(sInt)) > 0 Then
          Sheet1.Cells(r + 1, 1) = sInt
      Else
          MsgBox "您没有输入内容!"
      End If
  End Sub
       myInputBox过程使用InputBox函数显示一个对话框供用户在对话框中输入数据，InputBox函数显示一个对话框，等待用户输入正文或按下按钮，并返回包含文本框内容的字符串，语法如下：
InputBox(prompt[, title] [, default] [, xpos] [, ypos] [, helpfile, context]) 参数prompt是必需的，作为对话框消息出现的字符串表达式。
        参数title是可选的，作为显示在对话框标题栏中的字符串表达式，如果省略title参数，则在标题栏中显示“Microsoft Excel”。
        参数default是可选的，显示在文本框中的字符串表达式，在没有其它输入时作为缺省值，如果省略default参数，则文本框为空。
        参数xpos是可选的，指定对话框的左边与屏幕左边的水平距离。
如果省略xpos参数，则对话框会在水平方向居中。
        参数ypos是可选的，指定对话框的上边与屏幕上边的距离。
如果省略ypos参数，则对话框被放置在屏幕垂直方向距下边大约三分之一的位置。
        参数helpfile和参数context是可选的，为对话框提供上下文相关的帮助和编号，如果提供了其中一个参数，则必须提供另一个参数，两者缺一不可。
        第5行代码，使用InputBox函数显示一个提示用户输入邮政编码的对话框，其中“请输入人员姓名：”是必需的prompt参数，其他参数使用缺省值。
        第4行代码，使用Len函数和Trim函数判断返回的去除空格后的字符串长度。
如果字符串长度大于零，说明用户单击了对话框的“确定”按钮，则将用户输入的数据写到工作表的A列单元格。
如果返回的是长度为零的字符串，说明用户单击了对话框的“取消”按钮，则显示一条提示消息。
        因为当用户单击对话框的“确定”按钮后，InputBox函数返回包含文本框内容的字符串，如果用户单击对话框的“取消”按钮则返回一个长度为零的字符串（""），通过返回的字符串长度可以判断用户做出的选择。
        运行sInput过程将显示一个提示用户输入数据的对话框，如图所示。

75-2 使用对话框输入密码

使用InputBox函数显示的对话框输入密码简单方便，但有个明显的缺陷，就是输入过程中不能用占位符显示密码，不够安全。
借助API函数可以在输入密码过程中以占位符“*”号来显示密码，如下面的代码所示。

  Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
  Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  Public Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long, ByVal uResolution As Long, ByVal lpFunction As Long, ByVal dwUser As Long, ByVal uFlags As Long) As Long
  Public Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As Long
  Public Declare Function GetTickCount Lib "kernel32" () As Long
  Public Const EM_SETPASSWORDCHAR = &HCC
  Public lTimeID As Long
  Sub TimeProc(ByVal uID As Long, ByVal uMsg As Long, ByVal dwUser As Long, ByVal dw1 As Long, ByVal dw2 As Long)
      Dim hwd As Long
      hwd = FindWindow("
70", "密码")
      If hwd <> 0 Then
          hwd = FindWindowEx(hwd, 0, "edit", vbNullString)
          SendMessage hwd, EM_SETPASSWORDCHAR, 42, 0
          timeKillEvent lTimeID
      End If
    End Sub
  Sub Password()
      Dim Password As Variant
      lTimeID = timeSetEvent(10, 0, AddressOf TimeProc, 1, 1)
      Password = InputBox("请输入密码：", "密码")
      If Password = "123456" Then
          MsgBox "密码正确!"
      Else
          MsgBox "密码错误!"
      End If
  End Sub
       Password过程使用InputBox函数显示一个输入密码的对话框，并且以占位符“*”号显示输入的密码。
        第1行到第8行代码，API函数声明。
        第9行到第17行代码，TimeProc过程是timeSetEvent的回调函数，获得对话框句柄。
        第18行到第27行代码，Password过程显示一个提示用户输入密码的对话框。
        运行Password过程将显示一个密码输入框，输入的密码以占位符“*”号代替，如图所示。

点评
bluexuemei
又是又臭又长的API函数,太难理解

1

征婚启事
第6部分 使用对话框
技巧76 使用InputBox方法 在Excel中输入简单的数据可以使用InputBox函数显示的对话框，但是如果输入的数据类型不匹配时，过程运行时会产生意外错误。
为了避免此类情况发生，可以使用另一种获得用户输入的方式——InputBox方法。

76-1 输入指定类型的数据

使用InputBox方法输入数据时可以指定数据的类型，如下面的代码所示。

  Sub dInput()
      Dim dInput As Double
      Dim r As Integer
      r = Sheet1.Range("A65536").End(xlUp).Row
      dInput = Application.InputBox(Prompt:="请输入数字：", Type:=1)
      If dInput <> False Then
          Sheet1.Cells(r + 1, 1).Value = dInput
      Else
          MsgBox "你已取消了输入!"
      End If
  End Sub
       dInput过程使用InputBox方法显示一个提示用户输入数字的对话框。
        InputBox方法显示一个接收用户输入的对话框，返回此对话框中输入的信息，语法如下：
expression.InputBox(Prompt, Title, Default, Left, Top, HelpFile, HelpContextId, Type) 参数expression是必需的，返回一个Application对象。
        参数Prompt是必需的，作为对话框消息显示的字符串表达式。
        参数Title是可选的，作为显示在对话框标题栏中的字符串表达式。
如果省略Title参数，将使用默认的标题。
        参数Default是可选的，在对话框显示时出现在文本框中的初始值。
如果省略Default参数，则文本框为空。
        参数Left是可选的，指定对话框相对于屏幕左上角的 x 坐标。
        参数Top是可选的，指定对话框相对于屏幕左上角的 y 坐标。
        参数HelpFile和参数HelpContextId是可选的，为对话框提供上下文相关的帮助和编号，如果提供了其中一个参数，则必须提供另一个参数，两者缺一不可。
        参数Type是可选的，指定返回的数据类型。
如果省略Type参数，对话框将返回文本。
        InputBox方法的语法和InputBox函数的语法相似，最大的区别在于最后一个参数——Type。
通过Type参数可以指定返回值的数据类型，表格中列出了Type参数可以使用的数值。

       这些数值可以相加使用，如果希望返回数字和文本，可以将Type参数设置为1+2。
        InputBox方法与InputBox函数相比，优点是内置的出错处理。
在第5行代码中将Type参数值设置为1，这意味着对话框只能输入数值。
当用户输入的不是数值时，显示一个如图所示的消息框提示输入错误。

       第6行到第10行代码，如果用户单击对话框的“确定”按钮，将用户输入的数字写入工作表的A列单元格。
如果用户单击对话框的“取消”按钮，则显示一条提示消息。
        InputBox方法和InputBox函数的另一个区别是，当用户单击“取消”按纽时返回False而不是长度为零的字符串。
        运行dInput过程将显示一个提示用户输入数字的对话框，如图所示。

注意 在VBA代码中，Application.InputBox 调用的是InputBox方法，不带对象识别符的InputBox调用的是InputBox 函数。

76-2 获得单元格区域地址

InputBox方法很适合用户选择工作表单元格区域，并对所选择的单元格区域进行操作，如下面的代码所示。

  Sub RngInput()
      Dim rng As Range
      On Error GoTo line
      Set rng = Application.InputBox("请使用鼠标选择单元格区域：", , , , , , , 8)
      rng.Interior.ColorIndex = 15
  line:
  End Sub
       RngInput过程使用InputBox方法显示一个对话框，提示用户在工作表中选择一个单元格区域，并改变所选单元格区域内部的颜色。
        第3行代码，错误处理语句。
因为当对话框显示后，如果用户单击“取消”按钮，将显示一错误信息，如图所示，所以必需使用On Error GoTo语句来绕过错误。

       第4行代码，使用Set语句将用户选择的单元格区域赋给变量rng。
当Type参数设置为8时，将返回一个Range对象，必须用Set 语句将结果指定给一个Range对象。
        第5行代码，改变用户所选单元格区域内部的颜色。
        运行RngInput过程，将显示一个对话框，提示用户在工作表中选择一个单元格区域，并改变所选单元格区域内部的颜色，如图所示。

版主辛苦了。
非常受益，感谢感谢！ 保存指定工作表为工作薄文件，如果文件名称已经存在，就会报错。
代码中应该写才能强制覆盖旧文件？
加个错误处理吧Sub SheetCopy() On Error GoTo line ActiveSheet.Copy ActiveWorkbook.Close SaveChanges:=True, Filename:=ThisWorkbook.Path & "\SheetCopy.xls" Exit Sub line: ActiveWorkbook.Close False End Sub Sub ArrSheetCopy() On Error GoTo line Worksheets(Array("Sheet1", "Sheet2")).Copy ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\ArrSheetCopy.xls" ActiveWorkbook.Close SaveChanges:=True Exit Sub line: ActiveWorkbook.Close False End Sub

袁版，22楼代码中的Set rng = Nothing如何解释呢?我试了试，有无这行代码，运行结果都一样。
多谢。

对的，有无这行代码都是一样的，但这是一个好的编程习惯。
Nothing 关键字将对象变量从实际对象中分离开来，当对象变量被赋值为Nothing时，与被引用的对象有关联的内存资源及系统资源才会被释放掉。

第6部分 使用对话框
技巧77 内置对话框

77-1 调用内置的对话框

如果需要使用“打开”、“打印”等Excel内置对话框已经具有的功能，可以使用代码直接调用这些内置的对话框，如下面的代码所示。

  Sub DialogOpen()
      Application.Dialogs(xlDialogOpen).Show arg1:=ThisWorkbook.Path & "\*.xls"
  End Sub
       DialogOpen过程显示内置的“打开”对话框并选定示例所在的文件夹。
        显示内置对话框语法如下：
Application.Dialogs(xlDialogConst).Show Dialogs集合代表所有的内置对话框，每个Dialog对象代表一个内置对话框，不能新建内置对话框或向该集合中添加内置对话框。
        参数xlDialogConst是内置对话框的内置常量，每个常量都以“xlDialog”开头，其后是对话框的名称，如“打开”对话框的常量为“xlDialogOpen”。
常用内置对话框的内置常量如表格所示。

       显示内置对话框使用Show方法，应用于Dialog对象的Show方法语法如下：
expression.Show(Arg1, Arg2, Arg3, Arg4, Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, Arg12, Arg13, Arg14, Arg15, Arg16, Arg17, Arg18, Arg19, Arg20, Arg21, Arg22, Arg23, Arg24, Arg25, Arg26, Arg27, Arg28, Arg29, Arg30) 参数expression是必需的，返回Dialog对象之一。
        参数arg1到参数arg30是可选的，仅应用于内置对话框，是命令的初始参数。
若要查找要设置的参数，请在内置对话框参数列表中查找对应的对话框常量。
        运行alogOpen过程，显示内置的“打开”对话框，并且直接选定示例所在的文件夹，如图所示。

77-2 获取选定文件的文件名

如果只希望获取用户在显示的内置 “打开”对话框中选定文件的文件名，而不想真正打开该文件，那么可以使用GetOpenFilename方法，如下面的代码所示。

  Sub OpenFilename()
      Dim Filename As Variant
      Dim mymsg As Integer
      Dim i As Integer
      Filename = Application.GetOpenFilename(Title:="删除文件", MultiSelect:=True)
      If IsArray(Filename) Then
          mymsg = MsgBox("是否删除所选文件?", vbYesNo, "提示")
          If mymsg = vbYes Then
              For i = 1 To UBound(Filename)
                  Kill Filename(i)
              Next
          End If
      End If
  End Sub
       OpenFilename过程使用GetOpenFilename方法显示标准的内置“打开”对话框，获取用户选定文件的文件名后使用Kill语句删除。
        GetOpenFilename方法显示标准的内置“打开”对话框，获取文件名，语法如下：
expression.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect) 参数expression是必需的，返回一个Application对象。
        参数FileFilter是可选的，指定文件筛选条件的字符串。
如果省略，则默认参数值为“所有文件(*.*)”。
        参数FilterIndex是可选的，指定默认文件筛选条件的索引号，取值范围为 1 到由 FileFilter 所指定的筛选条件数目。
如果省略，或者取值大于可用筛选数目，则采用第一个文件筛选条件。
        参数Title是可选的，指定对话框的标题。
如果省略，则使用“打开”作为标题。
        参数ButtonText是可选的，仅用于Macintosh。
        参数MultiSelect是可选的，如果该值为True，则允许选定多个文件名，如果该值为False，则只允许选定单个文件名。
默认值为False。
        第5行代码显示标准的“打开”对话框，将对话框的标题设置为“删除文件”，将MultiSelect参数设置为True，允许选定多个文件。
        第6行代码，获得返回值。
当用户选定文件后，返回的是选定的文件名或用户输入的文件名。
因为MultiSelect参数已设置为True，所以返回值将是一个包含所有选定文件名的数组（即使仅选定了一个文件名）。
如果用户取消了对话框，则该值为False。
        第8行到第12行代码，经询问用户后使用Kill语句从磁盘中删除用户选定的文件。
        运行OpenFilename过程，显示标准的内置“打开”对话框，删除用户选定的文件，如所图示。

       注意 VBA中数组下界默认从0开始，但使用GetOpenFilename方法选择多个文件时返回的包含选定文件名的数组下界是从1开始。

77-3 使用

“另存为”对话框 在备份文件时可以使用GetSaveAsFilename方法显示标准的内置“另存为”对话框，获取备份文件的文件名和保存路径，而无须真正保存任何文件。
如下面的代码所示。

  Sub CopyFilename()
      Dim NowWorkbook As Workbook
      Dim FileName As String
      On Error GoTo line
      FileName = Application.GetSaveAsFilename _
          (InitialFileName:="D:" & Date & " " & ThisWorkbook.Name, _
          fileFilter:="Excel files(*.xls),*.xls,All files (*.*),*.*", _
          Title:="数据备份")
      If FileName <> "False" Then
          Set NowWorkbook = Workbooks.Add
          With NowWorkbook
              .SaveAs FileName
              ThisWorkbook.Sheets("Sheet2").UsedRange.Copy _
              .Sheets("Sheet1").Range ("A1")
              .Save
          End With
          GoTo line
      End If
      Exit Sub
  line:
      ActiveWorkbook.Close
  End Sub
       CopyFilename过程使用GetSaveAsFilename方法显示标准的内置“另存为”对话框，获取备份文件的文件名和保存路径，新建工作簿保存备份数据。
        第4行代码，错误处理语句。
备份过程中，如果已存在同名工作簿，会出现如图所示的提示，如果选择了“否”，此时新工作簿已经建立，在执行第12行代码时发生错误，使程序中断，所以使用GoTo语句执行第21行代码，关闭新建立的工作簿。

       第5行代码，使用GetSaveAsFilename方法显示标准的内置“另存为”对话框。
GetSaveAsFilename方法的语法如下：
expression.GetSaveAsFilename(InitialFilename, FileFilter, FilterIndex, Title, ButtonText) 参数expression是必需的，返回一个Application对象。
        参数InitialFilename是可选的，指定建议的文件名。
如果省略，将活动工作簿的名称作为建议的文件名。
        参数FileFilter是可选的，指定文件筛选条件的字符串。
        参数FilterIndex是可选的，指定默认文件筛选条件的索引号，取值范围为 1 到 FileFilter 指定的筛选条件数目之间。
如果省略，或者取值大于可用筛选数目，则采用第一个文件筛选条件。
        参数Title是可选的，指定对话框标题。
如果省略，则使用默认标题。
        参数ButtonText是可选的，仅用于 Macintosh。
        第6行代码，设置对话框的保存路径为D盘，保存文件名为日期加工作簿名称。
        第7行代码，设置对话框文件保存类型为Excel文件类型。
如果需要设置为文本类型需设置为“文本文件(*.txt), *.txt”，而如果是图片文件则需设置为“图片文件(*.bmp;*.jpg),* bmp;*.jpg”。
        第8行代码，设置对话框的标题为“数据备份”。
        第9行代码，如果用户没有取消操作。
        第10行到第16行代码，使用Add方法新建工作簿保存到对话框选定的路径中，将数据备份到新工作簿中。
        第17行代码，使用GoTo语句执行第21行代码，关闭新建工作簿和开启屏幕刷新。
        运行CopyFilename过程，显示内置“另存为”对话框，供用户备份工作簿数据，如图所示。

第6部分 使用对话框
技巧78 调用操作系统“关于”对话框 VBA程序开发完成后，有时需要一个“关于”对话框，除了使用窗体外，还可以调用操作系统的“关于”对话框，显示自定义的内容，如下面的代码所示。

  Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" ( _
          ByVal hwnd As Long, ByVal szApp As String, _
          ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
          ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Sub CommandButton1_Click()
      Dim ApphWnd As Long
      ApphWnd = FindWindow("XLMAIN", Application.Caption)
      ShellAbout ApphWnd, "财务处理系统", "yuanzhuping@yeah.net 0513-86548930", 0
  End Sub
       第1行到第5行代码是API函数声明。
        第8、9行代码调用操作系统的“关于”对话框并显示自定义的内容。
        代码运行后显示如图所示的对话框。

第6部分 使用对话框
第6部分使用对话框附件

VBA常用技巧（1-6）部分Word文档

 

1

foxfan2010
我在358楼的问题,望斑竹可以帮忙回复一下,谢谢!
http://club.excelhome.net/viewth ... ;page=36#pid2594572
44楼的禁用单元格拖放功能可行吗？
比如前面得到了copy长度为i，我要copy A2到H&i的单元格内容到另外一个sheet中
range("a2:h" & i )
有个问题想请教一下，请问我用查找的方法找到了所在的单元格，怎么能获得那个单元格所在的坐标呢？
坐标?单元格地址？ Rng.Address Range对象的Find方法返回的是一个Range对象，因此可以直接使用该对象的属性和方法。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=15
第7部分菜单和工具栏
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧79 在菜单中添加菜单项 在Excel工作表的菜单中可以添加新的菜单项和子菜单，如下面的代码所示。

  Sub myTools()
      Dim myTools As CommandBarPopup
      Dim myCap As Variant
      Dim myid As Variant
      Dim i As Byte
      myCap = Array("基础应用", "VBA程序开发", "函数与公式", "图表与图形", "数据透视表")
      myid = Array(281, 283, 285, 287, 292)
      With Application.CommandBars("Worksheet menu bar")
          .Reset
          Set myTools = .Controls("帮助(&H)").Controls.Add(Type:=msoControlPopup, Before:=1)
          With myTools
              .Caption = "Excel Home 技术论坛"
              .BeginGroup = True
              For i = 1 To 5
                  With .Controls.Add(Type:=msoControlButton)
                      .Caption = myCap(i - 1)
                      .FaceId = myid(i - 1)
                      .OnAction = "myC"
              End With
              Next
          End With
      End With
      Set myTools = Nothing
  End Sub
       myTools过程使用Add方法在Excel工作表菜单栏中的“帮助”菜单中添加一个标题为“Excel Home 技术论坛”的菜单项和5个子菜单。
        第2行到第5行代码声明变量类型。
        第6、7行代码使用Array函数创建两个数组用于保存子菜单的名称和图标ID。
        第9行代码，在添加菜单项前先使用Reset方法重置菜单栏以免重复添加菜单项。
Reset方法重置一个内置控件，恢复该控件原来对应的动作，并将各属性恢复成初始状态，语法如下：
expression.Reset 参数expression 是必需的，返回一个命令栏或命令栏控件对象。
        第10行代码，使用Add方法在Excel工作表菜单栏中的“帮助”菜单中添加菜单项。
Add方法应用于CommandBarControls对象时，新建一个CommandBarControl对象并添加到指定命令栏上的控件集合，语法如下：
       参数expression 是必需的，返回一个CommandBarControls对象，代表命令栏中的所有控件。
        参数Type是可选的，添加到指定命令栏的控件类型，可以为表格所列的MsoControlType常数之一。

       因为在本例中将添加的是带有子菜单的菜单项，所以将参数Type设置为弹出式控件。
        参数Id是可选的，标识整数。
如果将该参数设置为 1或者忽略，将在命令栏中添加一个空的指定类型的自定义控件。
        参数Parameter是可选的，对于内置控件，该参数用于容器应用程序运行命令。
对于自定义控件，可以使用该参数向Visual Basic过程传递信息，或用其存储控件信息。
        参数Before是可选的，表示新控件在命令栏上位置的数字。
新控件将插入到该位置控件之前。
如果忽略该参数，控件将添加到指定命令栏的末端。
        在本例中将Before参数设置为1，菜单项添加到“帮助”菜单的顶端。
        第12行代码，设定新添加菜单项的Caption属性为“Excel Home 技术论坛”。
Caption属性返回或设置命令栏控件的标题。
        第13行代码，设置新添加菜单项的BeginGroup属性为True，分组显示。
        第14行到第19行代码，在“Excel Home 技术论坛”菜单项上添加五个子菜单并设置其Caption属性、FaceId属性和OnAction属性。
        FaceId属性设置出现在菜单标题左侧的图标，以数字表示，一个数字代表一个内置的图标。
        OnAction属性设置一个VBA的过程名，该过程在用户单击子菜单时运行，本例中设置为下面的过程。

  Public Sub myC()
      MsgBox "您选择了： " & Application.CommandBars.ActionControl.Caption
  End Sub
       myC过程是单击新添加子菜单所运行过程，为了演示方便在这里只使用MsgBox函数显示所其Caption属性。
        删除新添加的菜单项及子菜单的代码如下所示。

  Sub DelmyTools()
      Application.CommandBars("Worksheet menu bar").Reset
  End Sub
       DelmyTools过程使用Reset方法重置菜单栏，删除添加的菜单项及子菜单。
        为了在打开工作簿时自动添加菜单项，需要在工作簿的Activate事件中调用myTools过程，如下面的代码所示。

  Private Sub Workbook_Activate()
      Call myTools
  End Sub

  Private Sub Workbook_Deactivate()
      Call DelmyTools
  End Sub
       运行myTools过程，将在Excel工作表菜单栏中的“帮助”菜单中添加一个名为“Excel Home 技术论坛”的菜单项及五个子菜单，如图所示。

第7部分 菜单和工具栏
技巧80 在菜单栏指定位置添加菜单 除了可以在工作表菜单中添加菜单项外，还可以在工作表菜单栏的指定位置添加菜单，如下面的代码所示。

  Sub AddNewMenu()
      Dim HelpMenu As CommandBarControl
      Dim NewMenu As CommandBarPopup
      With Application.CommandBars("Worksheet menu bar")
          .Reset
          Set HelpMenu = .FindControl(ID:=.Controls("帮助(&H)").ID)
          If HelpMenu Is Nothing Then
              Set NewMenu = .Controls.Add(Type:=msoControlPopup)
          Else
              Set NewMenu = .Controls.Add(Type:=msoControlPopup, _
                  Before:=HelpMenu.Index)
          End If
          With NewMenu
              .Caption = "统计(&S)"
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "输入数据(&D)"
                  .FaceId = 162
                  .OnAction = ""
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "汇总数据(&T)"
                  .FaceId = 590
                  .OnAction = ""
              End With
          End With
      End With
      Set HelpMenu = Nothing
      Set NewMenu = Nothing
  End Sub
       AddNewMenu过程使用Add方法在工作表“帮助”菜单前添加一个标题为“统计”的菜单和两个菜单项。
        第6行代码，使用FindControl方法在工作表菜单栏中查找“帮助”菜单。
应用于CommandBars对象的FindControl方法返回一个符合指定条件的CommandBarControl对象。
语法如下：
expression.FindControl(Type, Id, Tag, Visible, Recursive) 参数expression是必需的，返回一个CommandBars对象。
        参数Type是可选的，要查找控件的类型。
        参数Id是可选的，要查找控件的标识符。
        参数Tag是可选的，要查找控件的标记值。
        参数Visible是可选，如果该值为True，那么只查找屏幕上显示的命令栏控件。
默认值为False。
        参数Recursive是可选的，如果该值为True，那么将在命令栏及其全部弹出式子工具栏中查找。
此参数仅应用于CommandBar对象。
默认值为False。
        如果没有控件符合搜索条件，那么FindControl方法返回Nothing。
        第7行到第12行代码，如果工作表菜单栏中存在“帮助”菜单，将“统计”菜单添加到“帮助”菜单之前，否则添加到工作表菜单栏末尾。
        第12行到第25行代码，在“统计”菜单中添加两个子菜单并设置其各种属性。
        运行AddNewMenu过程，将在工作表菜单栏的“帮助”菜单之前添加一个“统计”菜单，如图所示。

如果想要再Sheet1中的A列单元格实现如下功能，如何编写代码？
想要实现的功能：例如，在A1单元格，在插入批注时，批注的内容会按要求的文本显示。
比如，“ 序列号：001 002 “
                在对A2单元格插 ...
80楼，

14-2 为单元格添加批注

，将代码稍做修改即可。

第7部分 菜单和工具栏
技巧81 屏蔽和删除工作表菜单 如果不希望用户使用工作表菜单栏的部分功能，可以把菜单或菜单项屏蔽或删除，如下面的代码所示。

  Sub Shibar()
      With Application.CommandBars("Worksheet menu bar")
          .Reset
          .Controls("工具(&T)").Controls("宏(&M)").Enabled = False
          .Controls("数据(&D)").Delete
      End With
  End Sub
       Shibar过程屏蔽 “工具”菜单中的“宏”菜单项，删除菜单栏中的“数据”菜单。
        第3行代码，使用Reset方法重置工作表菜单栏。
        第4行代码，将“宏”菜单项的Enabled属性设置为False，使之无效。
        Enabled属性决定命令栏或命令栏控件是否激活，如果将该属性设置为 False，那么该菜单项将无效。
        第5行代码，使用Delete方法将“数据”菜单从工作表菜单栏中删除。
        Delete方法应用于命令栏或命令栏控件时，从集合中删除指定对象，语法如下：
       参数expression是必需的，返回命令栏或命令栏控件对象之一。
        运行Shibar过程，将屏蔽工作表“工具”菜单中的“宏”菜单项和删除工作表菜单栏中的“数据”菜单，如图 所示。

 

第7部分 菜单和工具栏
技巧82 改变系统菜单的操作 利用VBA甚至可以改变系统菜单的默认操作，使之达到自定义菜单的效果，如下面的代码所示。

  Dim WithEvents Saveas As CommandBarButton
  Private Sub Workbook_Open()
      Set Saveas = Application.CommandBars("File").Controls("另存为(&A)...")
  End Sub
  Private Sub Saveas_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
      CancelDefault = True
      MsgBox "本工作簿禁止另存!"
  End Sub
       第1行代码，在模块级别中使用关键词WithEvents声明变量Saveas是用来响应由CommandBarButton对象触发事件的对象变量。
        第2行到第4代码工作簿的Open事件过程，在工作簿打开时将变量Saveas赋值为系统菜单的“另存为”菜单。
        因为在声明变量Saveas时使用了关键词WithEvents，不能同时使用New关键词隐式地创建对象，所以在使用变量Saveas之前，必须使用Set语句将变量赋值为一个已有对象。
         第5行到第8代码变量Saveas的单击事件过程，改变系统菜单“另存为”的默认操作。
        变量Saveas的Click事件在用户单击系统菜单“另存为”时发生，语法如下：
Private Sub CommandBarButton_Click(ByVal Ctrl As CommandBarButton, ByVal CancelDefault As Boolean) 参数Ctrl是必需的，指示初始化该事件的CommandBarButton控件。
        参数CancelDefault是必需的，Boolean类型，如果执行了与CommandBarButton控件关联的默认操作，该值为False。
除非其他过程或加载项取消了此操作。
         第6、7行代码，将CancelDefault参数设置为True，使单击“另存为”菜单时并不执行默认操作而只显示一个消息框。
        将工作簿保存、关闭后，重新打开，单击“另存为”菜单并不执行默认操作，只显示一个消息框，如图所示。

第7部分 菜单和工具栏
技巧83 定制自己的系统菜单 使用VBA开发的小型应用系统完成后，Excel原有的菜单栏完全可以舍弃不用，只使用自定义的菜单栏，更加方便快捷，如下面的代码所示。

  Sub AddNowBar()
      Dim NewBar As CommandBar
      On Error Resume Next
      With Application
          .CommandBars("Standard").Visible = False
          .CommandBars("Formatting").Visible = False
          .CommandBars("Stop Recording").Visible = False
          .CommandBars("toolbar list").Enabled = False
          .CommandBars.DisableAskAQuestionDropdown = True
          .DisplayFormulaBar = False
          .CommandBars("NewBar").Delete
      End With

      With NewBar
          .Visible = True
          With .Controls.Add(Type:=msoControlPopup)
              .Caption = "系统设置(&X)"
              .BeginGroup = True
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "保存(&S)"
                  .BeginGroup = True
                  .FaceId = 1975
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "备份(&B)"
                  .BeginGroup = True
                  .FaceId = 747
              End With
          End With
          With .Controls.Add(Type:=msoControlPopup)
              .Caption = "会计凭证(&P)"
              .BeginGroup = True
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "录入(&L)"
                  .BeginGroup = True
                  .FaceId = 197
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "审核(&S)"
                  .BeginGroup = True
                  .FaceId = 714
              End With
          End With
          With .Controls.Add(Type:=msoControlPopup)
              .Caption = "会计账簿(&Z)"
              .BeginGroup = True
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "记账(&L)"
                  .BeginGroup = True
                  .FaceId = 65
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "结账(&S)"
                  .BeginGroup = True
                  .FaceId = 47
              End With
          End With
          With .Controls.Add(Type:=msoControlPopup)
              .Caption = "会计报表(&B)"
              .BeginGroup = True
              With .Controls.Add(Type:=msoControlPopup)
                  .Caption = "资产负债表(&Y)"
                  .BeginGroup = True
                  With .Controls.Add(Type:=msoControlButton)
                      .Caption = "月报(&M)"
                      .BeginGroup = True
                      .FaceId = 1180
                  End With
                      With .Controls.Add(Type:=msoControlButton)
                          .Caption = "年报(&Y)"
                          .BeginGroup = True
                          .FaceId = 1188
                      End With
                  End With
              With .Controls.Add(Type:=msoControlPopup)
                  .Caption = "损益表(&S)"
                  .BeginGroup = True
                  With .Controls.Add(Type:=msoControlButton)
                      .Caption = "月报(&M)"
                      .BeginGroup = True
                      .FaceId = 1180
                  End With
                  With .Controls.Add(Type:=msoControlButton)
                      .Caption = "年报(&Y)"
                      .BeginGroup = True
                      .FaceId = 1188
                  End With
              End With
          End With
          With .Controls.Add(Type:=msoControlButton)
              .Caption = "退出系统(&C)"
              .BeginGroup = True
              .Style = msoButtonCaption
          End With
      End With
      Set NewBar = Nothing
  End Sub
       AddNowBar过程使用Add方法创建自定义菜单栏替换工作表菜单栏。
        第2行代码定义变量NewBar为命令栏。
        第3行代码忽略错误语句，以免第11行代码在删除可能不存在的“NewBar”菜单栏时发生错误。
        第5行代码隐藏“常用”工具栏。
        第6行代码隐藏“格式”工具栏。
        第7行代码隐藏“停止录制”工具栏。
        第8行代码屏蔽工具栏的右键快捷菜单。
        第9行代码屏蔽工具栏的“键入需要帮助的问题”下拉框。
        第10行代码屏蔽工具栏的编辑栏。
        第11行代码，在添加命令栏前先删除“NewBar”菜单栏，以免重复增加。
        第13行代码，使用Add方法创建命令栏。
Add方法应用于CommandBars对象的语法如下：
       参数expression是必需的，返回一个CommandBars对象，该对象代表应用程序中的命令栏，新建命令栏的控件均以该对象为载体。
        参数Name是可选的，设置新建命令栏的标题。
如果忽略该参数，则为新建命令栏指定默认标题，本例中设置新建命令栏的标题为“NewBar”。
        参数Position是可选的，设置新建命令栏的位置或类型，可以为表格所列的 MsoBarPosition常数之一。

       本例中设置“NewBar”命令栏的Position参数为msoBarTop，使“NewBar”命令栏位于Excel窗口的顶部。
        参数MenuBar是可选的，设置为True 将以新命令栏替换活动菜单栏，默认值为False。
        在本例中，设置“NewBar”命令栏的MenuBar属性为True，以“NewBar”命令栏替换活动菜单栏。
        第15行代码，设置“NewBar”命令栏为可见的。
        第16行到95行代码，使用Add方法在“NewBar”命令栏中添加菜单、菜单项及子菜单并设置其各项属性，参阅技巧79 。
        恢复Excel原有的菜单栏的代码如下：
  Sub DelNowBar()
      On Error Resume Next
      With Application
          .CommandBars("Standard").Visible = True
          .CommandBars("Formatting").Visible = True
          .CommandBars("Stop Recording").Visible = True
          .CommandBars("toolbar list").Enabled = True
          .CommandBars.DisableAskAQuestionDropdown = False
          .DisplayFormulaBar = True
          .CommandBars("NewBar").Delete
      End With
  End Sub
       DelNowBar过程取消 “常用”、“格式”和“停止录制”工具栏的的隐藏，恢复“键入需要帮助的问题”下拉框和编辑栏，删除“NewBar”命令栏。
        运行AddNowBar过程，工作表菜单栏如图所示。

range("a" & j :h" & i ) -----> 这样不行
j和i都是变量？ range("a" & j & ":h" & i ) Range(Cells(j, 1), Cells(i, 8))
第7部分 菜单和工具栏
技巧84 改变菜单按钮图标 利用VBA可以改变系统菜单的默认图标，使之达到自定义按钮图标的效果，如下面的代码所示。

  Sub myCbarCnt()
      Dim myCbarCnt As CommandBarControl
      With Sheet1.Shapes.AddShape(17, 1000, 1000, 30, 30)
          .Fill.ForeColor.SchemeColor = 29
          .CopyPicture
          .Delete
      End With
      Set myCbarCnt = Application.CommandBars("Standard").Controls(1)
      myCbarCnt.PasteFace
      Set myCbarCnt = Nothing
  End Sub
  Sub DelmyCbarCnt()
      Application.CommandBars("Standard").Controls(1).Reset
  End Sub
       myCbarCnt过程改变系统菜单的“新建”按钮的图标。
        第3行代码使用Shape对象的AddShape方法在工作表中新建一个自选图形。
应用于Shape对象的AddShape方法请参阅技巧53 。
        在本例中将新建图形的Left参数和Top参数设置为较大的数值使新建的自选图形不在当前窗口的可视区域内。
        第4行代码设置新建自选图形的颜色。
        第5行代码使用CopyPicture方法将新建自选图形作为图片复制到剪贴板。
CopyPicture方法的语法如下：
expression.CopyPicture(Appearance, Format) 参数expression是必需的，一个有效的对象。
        参数Appearance是可选的，指定图片的复制方式。
        参数Format是可选的，图片的格式。
        第6行代码使用Delete方法删除新建的自选图形。
        第8行代码使用Set语句将系统菜单的“新建”按钮赋给变量myCbarCnt。
        第9行代码PasteFace方法将新建的自选图形粘贴到“新建”按钮中。
PasteFace方法将“剪贴板”的内容粘贴到指定命令栏按钮控件上，语法如下：
expression.PasteFace 参数expression是必需的，返回一个CommandBarButton对象。
        DelmyCbarCnt过程使用Reset方法恢复“新建”按钮的默认图标。
        运行myCbarCnt过程结果如图所示。

第7部分 菜单和工具栏
技巧85 右键快捷菜单增加菜单项 在Excel的右键快捷菜单中可以添加新的菜单项，如下面的代码所示。

  Sub MyCmb()
      Dim MyCmb As CommandBarButton
      With Application.CommandBars("Cell")
          .Reset
          Set MyCmb = .Controls.Add(Type:=msoControlButton, _

              MyCmb.BeginGroup = True
          End With
      Set MyCmb = Nothing
  End Sub
       MyCmb过程使用Add方法在Excel的右键快捷菜单中添加内置的“打印”菜单项。
        运行MyCmb过程，将在Excel右键快捷菜单中添加 “打印”菜单项，如图所示。

这个只能对一行只有一个单元格有内容进行判断，如果一行中有多个单元格包含内容，只想删除完全一样的行，请问袁版应该把这句改成怎么样才能实现呢？ If WorksheetFunction.CountIf(.Columns(1), .Cells(i, 1)) > 1 ...
使用高级筛选，不重复数据。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=16
第7部分 菜单和工具栏
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧86 自定义右键快捷菜单 在工作表中创建自定义的右键快捷菜单替换Excel默认的右键快捷菜单，如下面的代码所示。

  Sub Mycell()
      With Application.CommandBars.Add("Mycell", msoBarPopup)
          With .Controls.Add(Type:=msoControlButton)
              .Caption = "会计凭证"
              .FaceId = 9893
          End With
          With .Controls.Add(Type:=msoControlButton)
              .Caption = "会计账簿"
              .FaceId = 284
          End With
          With .Controls.Add(Type:=msoControlPopup)
              .Caption = "会计报表"
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "月报"
                  .FaceId = 9590
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "季报"
                  .FaceId = 9591
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "年报"
                  .FaceId = 9592
              End With
          End With
          With .Controls.Add(Type:=msoControlButton)
              .Caption = "凭证打印"
              .FaceId = 9614
              .BeginGroup = True
          End With
          With .Controls.Add(Type:=msoControlButton)
              .Caption = "账簿打印"
              .FaceId = 707
          End With
          With .Controls.Add(Type:=msoControlButton)
              .Caption = "报表打印"
              .FaceId = 986
          End With
      End With
  End Sub
       Mycell过程在Excel工作表中创建自定义的右键快捷菜单。
        第2行代码，使用Add方法添加名称为“Mycell”命令栏，设置“Mycell”命令栏的Position属性为msoBarPopup，使“Mycell”命令栏为快捷菜单。
关于Position参数的MsoBarPosition常数请参阅技巧83 。
        第3行到第39行代码，使用Add方法在“Mycell”命令栏中添加菜单和菜单项，并设置其各项属性。
        为了让自定义右键快捷菜单替换Excel默认的右键快捷菜单，并且只在右键单击Sheet1工作表时显示，需要在Sheet1工作表的BeforeRightClick事件中写入下面的代码。

  Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
      Application.CommandBars("Mycell").ShowPopup
      Cancel = True
  End Sub
       工作表的BeforeRightClick事件过程，在右键单击工作表时，将“Mycell”命令栏作为右键快捷菜单，在当前光标位置显示。
        工作表BeforeRightClick事件语法如下：
Private Sub expression_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 参数expression是必需的，Worksheet类型对象。
        参数Target 是可选的，右键单击发生时最靠近鼠标指针的单元格。
        参数Cancel是可选的，当事件发生时为False。
如果在事件过程中将Cancel参数设为True，则该过程执行结束之后不进行默认的右键单击操作。
        第2行代码，使用ShowPopup方法将“Mycell”命令栏作为右键快捷菜单，在当前光标位置显示。
        ShowPopup方法的语法如下：
expression.ShowPopup(x, y) 参数expression是必需的，返回一个CommandBar对象。
        参数x是可选的，快捷菜单所在位置的 x 坐标。
如果省略此参数，将使用当前光标位置的x坐标。
        参数y是可选的，快捷菜单所在位置的y坐标。
如果省略此参数，将使用当前光标位置的y坐标。
        当用鼠标右键单击工作表中任意单元格时激活BeforeRightClick事件，此事件先于默认的右键单击操作。
在使用ShowPopup方法显示“Mycell”命令栏后，将Cancel参数设置为True，过程执行结束之后不进行默认的右键单击操作，Excel右键快捷菜单就不会显示。
        运行Mycell过程后，右键单击Sheet1工作表，在工作表中显示自定义右键快捷菜单，如图所示。

 

1

mythqiu
第7部分 菜单和工具栏
技巧87 使用右键菜单制作数据有效性 在工作表中输入数据时可以使用自定义右键菜单制作数据有效性，如下面的代码所示。

  Sub Mycell()
      Dim arr As Variant
      Dim i As Integer
      Dim Mycell As CommandBar
      On Error Resume Next
      Application.CommandBars("Mycell").Delete
      arr = Array("经理室", "办公室", "生技科", "财务科", "营业部")
      Set Mycell = Application.CommandBars.Add("Mycell", 5)
      For i = 0 To 4
          With Mycell.Controls.Add(1)
              .Caption = arr(i)
              .OnAction = "MyOnAction"
          End With
      Next
  End Sub
  Sub MyOnAction()
      ActiveCell = Application.CommandBars.ActionControl.Caption
  End Sub
       Mycell过程创建自定义的右键菜单，请参阅技巧86 。
        MyOnAction过程是点击自定义右键菜单所运行的过程，将所选右键菜单的名称写入活动单元格。
        为了使自定义的右键菜单在Sheet1工作表的特定区域中显示，需要在VBE中双击Sheet1表后写入下面的代码。

  Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
      If Target.Column = 2 Then
          Call Mycell
          Application.CommandBars("Mycell").ShowPopup
          Cancel = True
      End If
  End Sub
       工作表的BeforeRightClick事件过程，在右键单击工作表时，将“Mycell”命令栏作为右键快捷菜单，在当前光标位置显示，请参阅技巧86 。
        在工作表的B列中点击右键结果如图所示。

第7部分 菜单和工具栏
技巧88 禁用工作表右键菜单 有时并不希望用户使用工作表中的右键菜单对工作表进行操作，那么可以使用下面的代码禁用工作表右键菜单。

  Sub DisBar()
      Dim myBar As CommandBar
      For Each myBar In CommandBars
          If myBar.Type = msoBarTypePopup Then
              myBar.Enabled = False
          End If
      Next
  End Sub
       DisBar过程禁用工作表中所有的右键菜单。
        第3行代码使用For Each...Next 语句遍历CommandBars集合。
CommandBars集合代表应用程序中所有的命令栏。
        第4行代码根据命令栏的Type属性判断命令栏是否为右键菜单。
应用于 CommandBar对象的Type属性返回命令栏的类型，可以为表格所列的MsoBarType 常量之一。

       第5行代码将CommandBars集合中右键快捷菜的Enabled属性设置为False，使之无效。
        运行DisBar过程将禁用工作表中所有的右键菜单，需要恢复时只需将其Enabled属性设置为True即可。

袁版主，您好： 技巧10 禁用单元格拖放功能。
我发现，单元格被禁用拖放功能后如果想复制该单元格所在的行到另外一个工作簿的某一行，粘贴功能被禁止。

   也就是说，单元格被禁用拖放功能后是不能进行 ...
即然禁用了拖放功能也就禁用了复制粘贴功能，鱼和熊掌不可兼得。

感谢楼主,提一个问题,在工作簿中当选定某一工作表时自定义菜单显现,而选定其他表自定义菜单隐藏的代码如何写
工作表的Private Sub Worksheet_Activate()事件中添加，Private Sub Worksheet_Deactivate()事件中删除。

第7部分 菜单和工具栏
技巧89 创建自定义工具栏 为了方便用户操作，在Excel原有的的工具栏上，还可以创建自定义的工具栏，如下面的代码所示。

  Sub NowToolbar()
      Dim arr As Variant
      Dim id As Variant
      Dim i As Integer
      Dim Toolbar As CommandBar
      On Error Resume Next
      Application.CommandBars("MyToolbar").Delete
      arr = Array("会计凭证", "会计账簿", "会计报表", "凭证打印", "账簿打印", "报表打印")
      id = Array(9893, 284, 9590, 9614, 707, 986)
      Set Toolbar = Application.CommandBars.Add("MyToolbar", msoBarTop)
          With Toolbar
              .Protection = msoBarNoResize
              .Visible = True
              For i = 0 To 5
                  With .Controls.Add(Type:=msoControlButton)
                      .Caption = arr(i)
                      .FaceId = id(i)
                      .BeginGroup = True
                      .Style = msoButtonIconAndCaptionBelow
                  End With
              Next
          End With
      Set Toolbar = Nothing
  End Sub

代码解析： NowToolbar过程使用Add方法在Excel窗口中创建自定义工具栏。
应用于CommandBars对象的Add方法请参阅技巧83 。
        第10行代码，使用Add方法在菜单栏上创建名称为“MyToolbar”的命令栏，创建时设置新命令栏的Position参数为msoBarTop，使新命令栏位于应用程序窗口的顶部。
如果将Position参数设置成msoBarFloating，新命令栏为浮动工具栏，如图所示。

       关于Position参数的MsoBarPosition常数请参阅技巧83。
        第12行代码，设置“MyToolbar”命令栏的Protection属性为msoBarNoResize。
应用于CommandBar对象的Protection属性指定命令栏的保护类型，可以为表格所列的MsoBarProtection常数之一。

       第14行到第21代码，使用Add方法在新命令栏中添加按钮控件，设置按钮控件的各项属性。
其中第19行代码，设置按钮控件的Style属性为msoButtonIconAndCaptionBelow，使工具栏按钮显示时包含图标和标题，且标题位于图标之下。
        应用于CommandBar对象的Style属性返回或设置工具栏按钮的显示方式，可以为表格所列的MsoButtonStyle常数之一。

       运行NowToolbar过程，将在Excel窗口的顶部创建一个自定义的工具栏，如图所示。

第7部分 菜单和工具栏
技巧90 自定义工具栏按钮图标 在创建自定义的工具栏时，除了可以为工具栏按钮添加Excel内置的图标外，还能为工具栏按钮添加自定义的图标，如下面的代码所示。

  Sub AddCustomButton()
      Dim xBar As CommandBar
      Dim xButton As CommandBarButton
      On Error Resume Next
      Application.CommandBars("CustomBar").Delete
      Set xBar = CommandBars.Add("CustomBar", msoBarTop)
      Set xButton = xBar.Controls.Add(msoControlButton)
      With xButton
          .Picture = LoadPicture(ThisWorkbook.Path & "\P.BMP")
          .Mask = LoadPicture(ThisWorkbook.Path & "\M.BMP")
          .TooltipText = "Excel Home 论坛"
      End With
      xBar.Visible = True
      Set xBar = Nothing
      Set xButton = Nothing
  End Sub
       AddCustomButton过程创建自定义工具栏，并设置工具栏的按钮自定义图标。
        第6、7行代码，使用Add方法在Excel窗口中添加自定义工具栏和按钮。
请参阅技巧89 。
        第9行代码，设置工具栏按钮的Picture属性为同一目录中的p.bmp图片。
        应用于CommandBarButton 对象的Picture属性返回一个IPictureDisp对象，表示 CommandBarButton对象的图像，语法如下：
expression.Picture 参数是必需的，返回一个CommandBarButton对象。
        指定对象的Picture属性就能设置对象的图像。
        第10行代码，设置工具栏按钮的Mask属性为同一目录中的m.bmp图片。
        为了使工具栏按钮图标透明显示，在指定对象的Picture属性后，还需要指定对象的Mask属性。
        应用于CommandBarButton 对象的Mask属性返回表示CommandBarButton对象的屏蔽图像的IPictureDisp对象，语法如下：
expression.Mask 参数是必需的，返回一个CommandBarButton对象。
        屏蔽图像决定按钮图像透明的部分。
在创建作为屏蔽图像使用的图像时，所有要透明的区域应该为白色，所有要显示的区域应该为黑色。
        第11行代码，设置按钮的“屏幕提示”为“ExcelHome论坛”。
        运行AddCustomButton过程，创建自定义工具栏，并设置工具栏按钮的图标，如图所示。

第7部分 菜单和工具栏
技巧91 自定义工作簿图标 Excel标题栏的图标是默认的，而借助API函数可以自定义工作簿标题栏图标，如下面的代码所示。

  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
  Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
  Private Const WM_SETICON = &H80
  Private Sub Workbook_Open()
      Dim IStyle As Long
      Dim hIcon As Long
      Dim hWndForm As Long
      hWndForm = FindWindow(vbNullString, Application.Caption)
      hIcon = ExtractIcon(0, ActiveWorkbook.Path & "\p.bmp", 0)
      SendMessage hWndForm, WM_SETICON, True, hIcon
      SendMessage hWndForm, WM_SETICON, False, hIcon
  End Sub
       工作簿打开后使用API函数自定义工作簿标题栏的图标。
        第1行到第6行代码，API函数声明。
        第7行到第15行代码，工作簿的Open事件过程，把工作簿标题栏默认的图标更改为同一文件夹下的p.bmp图片。
        工作簿打开后标题栏如图所示。
               任务栏图标如图所示。
       
版主辛苦了。
如何添加自定义菜单和工具栏的命令？是不是下一课要讲。

第7部分的不就是自定义菜单和工具栏？
第7部分 菜单和工具栏
技巧92 移除工作表的最小最大化和关闭按钮 如果不希望工作表的最小、最大化和关闭按钮出现在菜单栏中，可以使用以下代码去除：ActiveWorkbook.Protect , , True
       使用Protect方法对工作簿进行保护。
Protect方法应用于Workbook对象的时保护工作簿使其不至被修改，语法如下：
expression.Protect(Password, Structure, Windows) 参数expression是必需的，该表达式返回一个Workbook对象。
        参数Password是可选的，为工作表或工作簿指定区分大小写的密码。
        参数Structure是可选的，如果为True，则保护工作簿结构（工作表的相对位置）。
默认值为False。
        参数Windows是可选的，如果为True，则保护工作簿窗口。
        恢复工作表的最大、最小化和关闭按钮的代码如下：ActiveWorkbook.Protect , , False

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=17
本帖已被收录到知识树中，索引项：开发帮助和教程
第7部分 菜单和工具栏 技巧88 禁用工作表右键菜单
请教楼主： 我测试了这个后，excel工作表右键菜单不能用了。
必须再次打开你的附件中工作簿点击启用才能。
如何解决？
不会呀，在工作簿事件中有恢复的。
Private Sub Workbook_Deactivate() Call EnaBar End Sub

袁斑竹,不介意我把这里的技巧整理成一本书发到论坛上吧!!!!!!!!!!!!
如果是发到EH论坛当然不介意，我也想整理完成后请人制作成电子书供大家下载。

第7部分 菜单和工具栏
技巧93 在工具栏上添加下拉列表框 如果需要在工具栏中添加类似“字体”这样的下拉列表控制框控件，那么可以使用下面的代码。

  Sub AddDropdown()
      Dim myDropdown As Object
      Dim myCap As Variant
      Dim i As Integer
      myCap = Array("基础应用", "VBA程序开发", "函数与公式")
      Call DeleteButton
      Set myDropdown = Application.CommandBars("Formatting").Controls _
          .Add(Type:=msoControlDropdown, Before:=1)
      With myDropdown
          .Caption = "请选择版块"
          .OnAction = "myOnA"
          .Style = msoComboNormal
          For i = 0 To UBound(myCap)
              .AddItem myCap(i)
          Next
          .ListIndex = 1
      End With
  End Sub
  Sub DeleteButton()
      With Application.CommandBars("Formatting").Controls(1)
          If .Caption = "请选择版块" Then .Delete
      End With
  End Sub
  Sub myOnA()
      Dim myList As Byte
      myList = Application.CommandBars("Formatting") _
          .Controls(1).ListIndex
      ActiveWorkbook.FollowHyperlink _
      Address:="http://club.excelhome.net/forum-" & myList & "-1.html", NewWindow:=True
  End Sub
       AddDropdown过程使用Add方法在工具栏中添加下拉列表控制框控件。
        第5行代码使用Array函数创建一个数组用于保存下拉列表控制框控件加载列表项所需的元素。
         第6行代码先运行第19行到第23行的DeleteButton过程删除可能存在的下拉列表控制框控件，以免重复添加。
DeleteButton过程判断工具栏中第一个控件的Caption属性是否为“请选择版块”，如果是则删除该下拉列表控制框控件。
        第7、8行代码使用Add方法在工具栏中添加下拉列表控制框控件。
应用于 CommandBarControls 对象的Add方法请参阅技巧79 。
示例中将其参数Type设置为msoControlDropdown，添加的就是下拉列表控制框控件。
        第10行代码设置下拉列表控制框控件的Caption属性，应用于 CommandBarControls 对象的Caption属性返回或设置指定命令栏控件的题注文字，也可作为默认的“屏幕提示”显示。
        第11行代码设置改变下拉列表控制框控件的内容时要运行的过程为第24行到第30行代码的myOnA过程。
myOnA过程根据下拉列表控制框控件的ListIndex属性值打开Excel Home论坛中相应的版块。
        第12行代码设置下拉列表控制框控件的样式。
Style属性返回或设置命令栏控件的显示方式，该属性值可设置为表格所列MsoComboStyle常量之一。

       第13行到第15行代码使用AddItem方法将数组中的元素添加到下拉列表控制框控件的列表项中。
        第16行代码将下拉列表控制框控件的ListIndex属性设置为1，使其显示第一条列表项。
        运行AddDropdown过程，工具栏如图所示。

第7部分 菜单和工具栏
技巧94 屏蔽工作表的复制功能 有时我们并不希望用户对工作表中的数据进行复制粘贴操作，此时可以把所有的复制功能都屏蔽，如下面的代码所示。

      Dim CmdCtrls As CommandBarControls
      Dim Cmd As CommandBarControl
  Sub ProCopy()
      Set CmdCtrls = Application.CommandBars.FindControls(ID:=19)
      For Each Cmd In CmdCtrls
          Cmd.Enabled = False
      Next
      Application.CellDragAndDrop = False
      Application.OnKey ("^c"), ""
  End Sub
  Sub StaCopy()
      Set CmdCtrls = Application.CommandBars.FindControls(ID:=19)
      For Each Cmd In CmdCtrls
          Cmd.Enabled = True
      Next
      Application.CellDragAndDrop = True
      Application.OnKey ("^c")
  End Sub
       第1、2行代码在模块顶部声明两个模块级的变量。
        第3行到第10行代码ProCopy过程，屏蔽工作表中所有的复制功能。
其中第4行到第7行代码使用FindControls方法将所有与“复制”相关的命令栏控件赋给变量CmdCtrls后将其Enabled设置为False。
关于FindControls方法请参阅技巧80 。
        第8行代码屏蔽单元格拖放功能，关于应用于Application对象的CellDragAndDrop属性请参阅技巧10 。
        第9行代码屏蔽<Ctrl+C>组合键功能，关于应用于Application 对象的OnKey方法请参阅技巧68 。
        第11行到第18行代码StaCopy过程，恢复所有的复制功能。

yuan版主：您好！您真是太辛苦了。
请教一个问题：若将技巧27 自动建立工作表目录的工作表名称从E6：J6向下排放，怎么写代码呀？谢谢！ Private Sub Worksheet_Activate() Dim sh As Worksheet Dim a As Integer Dim R As Integer Dim rng As Range R = Abs(Int(-(Worksheets.Count - 1) / 6)) + 5 a = 1 Set rng = Sheet1.Range("E6:J" & R) rng.ClearContents For Each sh In Worksheets If sh.CodeName <> "Sheet1" Then rng(a) = sh.Name a = a + 1 End If Next End Sub

真的谢谢您，版主！不过关于超连接的代码没有写呀？ Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim R As Integer R = Sheet1.[E65500].End(xlUp).Row On Error Resume Next If Target.Count = 1 Then If Not Application.Intersect(Target, Range("E6:J" & R)) Is Nothing Then Sheets(Target.Value).Select End If End If End Sub

第7部分 菜单和工具栏
技巧95 禁用工具栏的自定义 在Excel中，用户可以通过依次单击菜单“视图”→“工具栏”→“自定义”，显示“自定义”选项卡来调整菜单栏和工具栏，如图所示。

       如果不希望用户使用“自定义”选项卡来调整菜单栏和工具栏，可以禁用工具栏的自定义功能，如下面的代码所示。

  Sub nCustomize()
      Application.CommandBars.DisableCustomize = True
  End Sub
       nCustomize 过程禁用工具栏的自定义功能，应用于CommandBars 集合对象的DisableCustomize属性设置是否禁用工具栏的自定义。
如果禁用，返回True，否则返回False。
        用于启用工具栏的自定义的代码是：
  Sub yCustomize()
      Application.CommandBars.DisableCustomize = False
  End Sub

第7部分 菜单和工具栏
技巧96 屏蔽所有的命令栏 在使用自定义的操作界面时，需要屏蔽Excel中所有的命令栏，可以使用下面的代码。

  Sub Shielding_1()
      Dim i As Integer
      For i = 1 To Application.CommandBars.Count
          Application.CommandBars(i).Enabled = False
      Next
  End Sub
       Shielding_1过程使用For...Next语句遍历Excel命令栏，并将其Enabled属性设置为False，使之无效。
        还可以使用For Each...Next 语句遍历所有的CommandBars对象，代码如下：
  Sub Shielding_2()
      Dim Cmd As CommandBar
      For Each Cmd In Application.CommandBars
          Cmd.Enabled = False
      Next
  End Sub

       在需要恢复时只需将Enabled属性设置为True即可，如下面的代码所示。

  Sub Recovery_1()
      Dim i As Integer
      For i = 1 To Application.CommandBars.Count
          Application.CommandBars(i).Enabled = True
      Next
  End Sub
  Sub Recover_2()
      Dim Cmd As CommandBar
      For Each Cmd In Application.CommandBars
          Cmd.Enabled = True
      Next
  End Sub
       Recovery_1和Recover_2过程分别使用For...Next语句和For Each...Next 语句遍历所有的CommandBars对象，设置其Enabled属性为True，显示所有的命令栏。

第7部分 菜单和工具栏
技巧97 恢复Excel的命令栏 如果用户经常添加、删除Excel的菜单和工具栏而又没有及时恢复的话，有时会破坏Excel默认的用户界面，即使用Reset方法也不能恢复成初始状态。
        此时可以在电脑的本地硬盘中查找扩展名为*.xlb的文件，该文件在电脑中的位置会因Excel版本的不同而不同，在XP操作系统中，该文件位于系统盘的Documents and Settings\Administrator\Application Data\Microsoft\Excel文件夹，其中Administrator是电脑的用户名。
找到它最简单的方法是使用Windows的搜索功能。
按<Win+F>组合键调出Windows的搜索窗口，然后用*.xlb为目标在本地硬盘中进行搜索，如图所示。

       如果搜索没有结果，请检查“更多高级选项”中是否选中“搜索隐藏的文件和文件夹”选项，如图所示。

       对Excel用户界面的任何修改都会保存在*.xlb文件中，找到后删除该文件，然后重新启动Excel。
Excel会重新创建一个*.xlb文件，而菜单和工具栏也会全部恢复成初始状态。

询问 袁版主：您好！您编写的这些代码技巧都是适用03版的EXCEL，好像有些对07版的不适用耶？？？
是的，所有的代码都是在2003版中进行过测试，2007版的有些代码不适用，我现在用的是2003版的，不喜欢2007版的界面，所以一直没用，现在看来落后了，使用2007版的人很多了。
 关于进度条宏代码与执行的宏同步事宜 袁版主：您好！再次麻烦您。
通常相关资料制作的进度条都是他们自己举的例子进行运算，来测试进度条的进度。
现在请问实际要运行的代码怎样与进度条同步呀？谢谢！下面是测试的进度条代码与本人需要运行的工资条的宏，怎样才能在运行工资条的宏时与进度条同步？
关于这个问题以前也讨论过，一般认为如果程序中有循环，那么可以把进度条嵌入到程序的循环中，可以做到同步，否则很难做到同步运行。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=18
第7部分 菜单和工具栏
本帖已被收录到知识树中，索引项：开发帮助和教程
1-7部分Word文档

第7部分 菜单和工具栏附件

第8部分 控件的应用
技巧98 限制文本框的输入 用户在使用文本框输入数据时，往往希望能限制输入数据的类型，比如只能输入数字。
但是没有内置的属性能限制在文本框中只能输入数字，只能在文本框的事件过程中使用代码来测试输入的是哪类字符，然后只允许输入数字字符和一个“-”号、一个“.”号，如下面的代码所示。

  Private Sub TextBox1_KeyPress(ByVal KeyANSI As MSForms.ReturnInteger)
      Select Case KeyANSI
          Case Asc("0") To Asc("9")
          Case Asc("-")
              If InStr(1, Me.TextBox1.Text, "-") > 0 Or _
                  Me.TextBox1.SelStart > 0 Then
                  KeyANSI = 0
              End If
          Case Asc(".")
              If InStr(1, Me.TextBox1.Text, ".") > 0 Then
                  KeyANSI = 0
              End If
          Case Else
              KeyANSI = 0
      End Select
  End Sub
       文本框的KeyPress事件过程，测试键盘输入的是哪类字符，只允许输入数字字符和一个“-”号、一个“.”号。
 KeyPress事件的语法如下：
Private Sub object_KeyPress( ByVal KeyANSI As MSForms.ReturnInteger) 参数Object是必需的，一个有效的对象。
        参数KeyANSI是可选的，整数值，代表标准的数字ANSI 键代码。
        第2行代码使用Case Else语句测试文本框KeyPress事件的KeyANSI参数值。
        第3行代码，如果键盘输入的是0到9之间的数字字符，则允许输入。
如果想在文本框中允许其它类型的字符输入，在此句代码中列出允许输入的字符即可。
        第4行到第8行代码，如果键盘输入的是“-”号，先使用InStr函数测试文本框中是否已有“-”号，如果InStr函数返回值大于0，说明文本框中已有“-”号。
接下来使用文本框的SelStart 属性来测试插入点，如果文本框的SelStart 属性值大于0，说明“-”号的插入点不是第一个。
如果以上两个条件中有任何一个成立，将KeyAscii参数值设置为0，使文本框只能在第一位输入一个“-”号。
        第9行到第12行代码，如果键盘输入的是“.”号的话，使用InStr函数测试文本框中是否已有“.”号，如果已有“.”号，将KeyAscii参数值设置为0，使文本框只能输入一个“.”号。
        第13、14行代码，如果键盘输入的是其他字符则将KeyAscii参数值设置为0，使文本框不能输入其他字符。
        经过以上设置文本框只允许输入数字字符和一个“-”号、一个“.”号，但是能输入中文字符。
如果希望限制中文字符的输入，可以在文本框的Change事件中进行设置，如下面的代码所示。

  Private Sub TextBox1_Change()
      Dim i As Integer
      Dim s As String
      With TextBox1
          For i = 1 To Len(.Text)
              s = Mid(.Text, i, 1)
              Select Case s
                  Case ".", "-", "0" To "9"
                  Case Else
                      .Text = Replace(.Text, s, "")
              End Select
          Next
      End With
  End Sub
       文本框的Change事件，判断输入的字符是否为数字字符和“-”号、“.”号，如果不是则使用Replace函数将文本框中输入的其他字符替换成空白。
        第5、6行代码在文本框输入的所有字符中循环。
        第8行代码列出允许输入的字符。
如果想在文本框中允许其它字符输入，在此句代码中列出即可。
        第9、10行代码，如果不是允许输入的字符，使用Replace函数替换成空白。
        经过以上的设置，文本框中只能在第一位输入一个“-”号、一个“.”号和“0”到“9”的数字。

第8部分 控件的应用
技巧99 文本框添加右键快捷菜单 VBA中的控件没有提供右键快捷菜单，用户可以使用Excel 中的命令栏自已添加右键快捷菜单。
        步骤1：按<Alt+F11>组合键进入VBE窗口，单击菜单“插入”→“模块”，在其代码窗口输入以下代码：
  Private ActiveTB As MSForms.TextBox
  Public Sub CreateShortCutMenu()
      Dim ShortCutMenu As CommandBar
      Dim ShortCutMenuItem As CommandBarButton
      Dim sCaption As Variant
      Dim iFaceId As Variant
      Dim sAction As Variant
      Dim i As Integer
      sCaption = Array("剪切(&C)", "复制(&T)", "贴粘(&P)", "删除(&D)")
      iFaceId = Array(21, 19, 22, 1786)
      sAction = Array("Action_Cut", "Action_Copy", "Action_Paste", "Action_Delete")
      On Error Resume Next
      Application.CommandBars("ShortCut").Delete
      Set ShortCutMenu = Application.CommandBars.Add("ShortCut", msoBarPopup)
      With ShortCutMenu
          For i = 0 To 3
              Set ShortCutMenuItem = .Controls.Add(msoControlButton)
              With ShortCutMenuItem
                  .Caption = sCaption(i)
                  .faceID = Val(iFaceId(i))
                  .OnAction = sAction(i)
              End With
          Next
      End With
  End Sub
       第1行代码，在模块级别中声明变量ActiveTB是用来对应窗体中的文本框所触发的所有事件的变量。
        CreateShortCutMenu过程用来创建标题为“ShortCut”的右键快捷菜单，并添加4个菜单项。
关于自定义右键快捷菜单请参阅技巧86 。

  Public Sub ShowPopupMenu(txtCtr As MSForms.TextBox)
      Dim Action As Variant
      Set ActiveTB = txtCtr
      With Application.CommandBars("ShortCut")
          .Controls(1).Enabled = txtCtr.SelLength > 0
          .Controls(2).Enabled = .Controls(1).Enabled
          .Controls(3).Enabled = txtCtr.CanPaste
          .Controls(4).Enabled = .Controls(1).Enabled
          .ShowPopup
      End With
  End Sub
       ShowPopupMenu过程根据文本框中字符的选中状态设置右键快捷菜单菜单项的Enabled属性后使用ShowPopup方法显示右键快捷菜单。
        第5行代码，如果当前文本框中已有选中的字符则“剪切”按钮有效。
        第6行代码，如果当前文本框中已有选中的字符则“复制”按钮有效。
        第7行代码，如果剪贴板中包含对象支持的数据。
则“贴粘”按钮有效。
        第8行代码，如果当前文本框中已有选中的字符则“删除”按钮有效。
        第9行代码，显示快捷菜单。

  Public Sub Action_Cut()
      ActiveTB.Cut
  End Sub
  Public Sub Action_Copy()
      ActiveTB.Copy
  End Sub
  Public Sub Action_Paste()
      ActiveTB.Paste
  End Sub
  Public Sub Action_Delete()
      Dim s As String
      With ActiveTB
          s = .SelText
          .Value = Replace(.Value, s, "")
      End With
  End Sub
       Action_Cut过程是快捷菜单中单击“剪切”菜单项所运行的过程。
使用Cut 方法将当前选中的文本框中的文本删除并移至剪贴板。
        Action_Copy过程是快捷菜单中单击“复制”菜单项所运行的过程。
使用Copy方法将文本框选中的文本复制到剪贴板上。
        Action_Paste过程是快捷菜单中单击“贴粘”菜单项所运行的过程。
使用Paste方法把剪贴板上的内容传送到一个文本框中。
        Action_Delete过程是快捷菜单中单击“贴粘”菜单项所运行的过程。
使用Replace函数将文本框中选中的文本的文本替换成空字符。

  Public Sub DeleteShortCutMenu()
      On Error Resume Next
      Application.CommandBars("ShortCut").Delete
  End Sub
       DeleteShortCutMenu过程删除创建的右键快捷菜单。
        步骤2：在VBE窗口中，单击菜单“插入”→“用户窗体”，在窗体上添加两个文本框控件。
双击窗体，在其代码窗口中输入下面的代码。

  Private Sub UserForm_Initialize()
      Call CreateShortCutMenu
  End Sub
  Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
      If Button = 2 Then ShowPopupMenu ActiveControl
  End Sub
  Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
      If Button = 2 Then ShowPopupMenu ActiveControl
  End Sub
  Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
      Call DeleteShortCutMenu
  End Sub
       第1行到第3行代码，窗体的Initialize事件，在窗体初始化时运行CreateShortCutMenu过程创建右键快捷菜单。
        第4行到第9行代码，文本框的MouseUp事件，当用户右健单击文本框时运行ShowPopupMenu过程在选中的菜单项上显示右键快捷菜单。
        第10行到第12行代码，窗体的QueryClose事件，在关闭窗体时运行DeleteShortCutMenu过程删除右键快捷菜单。
        窗体运行后，右键单击文本框显示右键快捷菜单，如图所示。

版主你好，很感谢你能为大家上传这些资料。
我想请教一下怎样在exce中能使按钮根据鼠标的位置实现动态效果。

按钮跟随活动单元格吗？在工作表的SelectionChange事件中设置按钮的Top属性等于选定单元格的Top属性，按钮的Left属性等于选定单元格的Left属性加上选定单元格的宽度，即按钮出现在选定单元格的右边。

第8部分 控件与用户窗体
技巧100 文本框回车自动输入 在使用文本框向工作表输入数据时，为了加快输入速度，可以利用文本框的KeyDown事件，回车后自动输入并清空文本框，如下面的代码所示。

  Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      With TextBox1
          If Len(Trim(.Value)) > 0 Then
              If KeyCode = vbKeyReturn Then
                  Sheet1.Range("A65536").End(xlUp).Offset(1, 0) = .Value
                  .Text = ""
              End If
          End If
      End With
  End Sub
       文本框的KeyDown事件，在输入数据并按<Enter>键后自动将数据录入到工作表A列最后一个非空单元格的下一个单元格中。
        KeyDown事件在按下键盘按键时发生，语法如下：
Private Sub object_KeyDown( ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As fmShiftState) 参数object是必需的，一个有效的对象。
        参数KeyCode是必需的，代表被按下的键的键代码。
        参数Shift是可选的，Shift、Ctrl 和Alt的状态。
        第3行代码，为了防止误输入空白数据，使用Len 函数和Trim 函数检查文本框内是否为有效数据。
        第4行代码，根据KeyCode参数值判断是否按下了回车键。
如果用户按下了回车键，KeyCode参数返回常数vbKeyReturn。
        第5、6行代码，将文本框数据输入到工作表A列的最后一个单元格内，同时清空文本框内容准备下一次输入。

 

第8部分 控件与用户窗体
技巧101 自动选择文本框内容 如果希望光标进入文本框时能自动选择文本框内容，可以在文本框的MouseUp事件中来完成，如下面的代码所示。

  Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
      With TextBox1
          If Button = 2 Then
              .SelStart = 0
              .SelLength = Len(.Text)
          End If
      End With
  End Sub
       文本框的MouseUp事件，在光标进入文本框释放鼠标右键时自动选择文本框内容。
        MouseUp事件在用户释放鼠标按键时发生，语法如下：
Private Sub object_MouseUp( ByVal Button As fmButton, ByVal Shift As fmShiftState, ByVal X As Single, ByVal Y As Single) 参数object是必需的，一个有效的对象。
        参数Button是可选的，设置引起该事件的鼠标按键的整数值，如表格所示。

       参数Shift是可选的，Shift、Ctrl 和Alt的状态。
        参数X和参数Y是可选的，窗体、框架或页的位置的横坐标与纵坐标。
        第3行到第6行代码，如果用户进入文本框释放鼠标右键，设置文本框的SelStart 属性为0，SelLength属性为文本框的全部字符数。
        SelStart 属性指定选中文本的起点，语法如下：
object.SelStart [= Long] 参数object是必需的，一个有效的对象。
        参数Long是可选的，指定选中文本的起点。
        SelLength 属性指定文本框或组合框的文本部分中选中的字符数，语法如下：
object.SelLength [= Long] 参数object是必需的，一个有效的对象。
        参数Long是可选的，指定选中的字符数。
        运行窗体，当光标进入文本框释放鼠标右键时自动选择文本框内容，如图所示。

 

第8部分 控件与用户窗体
技巧102 设置文本框数据格式 文本框在用来输入数据时，除了限制输入的数据类型外，还可以设置文本框的数据格式，如下面的代码所示。

  Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
      TextBox1 = Format(TextBox1, "0.00")
  End Sub
  Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
      TextBox2 = Format(TextBox2, "0.00")
  End Sub
       文本框的Exit事件过程，在文本框输入数据时使用Format函数格式化为两位小数格式。
        控件的Exit事件在同一窗体中的一个控件即将把焦点转移到另一个控件之前发生，语法如下：
Private Sub object_Exit( ByVal Cancel As MSForms.ReturnBoolean) 参数Object是必需的，一个有效的对象。
        参数Cancel是必需的，事件状态。
如果设置为False表示由该控件处理这个事件（默认方式）。
设置为True表示由应用程序处理这个事件，并且焦点留在当前控件上。
        当文本框在输入完数据失去焦点时使用Format函数格式化自定义数值格式。
Format函数语法如下：
Format(expression[, format[, firstdayofweek[, firstweekofyear]]]) 参数expression是必需的，任何有效的表达式。
        参数format是可选的，有效的命名表达式或用户自定义格式表达式。
        参数firstdayofweek是可选的，常数，表示一星期的第一天。
        参数firstweekofyear是可选的，常数，表示一年的第一周。
        在本例中，将文本框的数据格式化成自定义的两位小数的数值格式，关于Format函数格式化日期和时间等其他数据请参阅VBA中Format函数的帮助。

  Private Sub TextBox1_Change()
      TextBox3 = Format(Val(TextBox1) * Val(TextBox2), "0.00")
  End Sub
  Private Sub TextBox2_Change()
      TextBox3 = Format(Val(TextBox1) * Val(TextBox2), "0.00")
  End Sub
       文本框的Change事件过程，在两个文本框输入完数据后，使用文本框的Change事件使TextBox3显示其相乘的金额并格式化为两位小数的数据格式。
        Change事件在控件的 Value 属性改变时发生，语法如下：
Private Sub object_Change( ) 参数object是必需的，一个有效的对象。
        Change事件过程可以使显示在控件上的数据同步或一致。
在本例中，当TextBox1或TextBox2的数据发生改变时，两者相乘的金额的金额也随之改变并在TextBox3中显示。
        因为文本框的数据类型是文本字符串，不能直接进行计算的，所以计算前先使用Val函数转换为数字，才能进行计算。
        运行窗体，输入数据后格式化为两位小数的数据格式，如图所示。

 

第8部分 控件与用户窗体
技巧103 限制文本框的输入长度 在使用文本框输入数据时，可能希望限制能输入的字符长度，即只能输入一定长度的字符，超过设置数值就不能输入，这时可以通过设置文本框的MaxLength属性来实现，如下面的代码所示。

  Private Sub Worksheet_Activate()
      Me.TextBox1.MaxLength = 6
  End Sub
       工作表的激活事件过程，将文本框的MaxLength属性设置为6，使文本框只能输入6个字符，超过6个字符即不能输入。
        应用于文本框控件的MaxLength属性规定用户可以在文本框中输入的最多字符数，语法如下：
object.MaxLength [= Long] 参数object是必需的，一个有效的对象。
        参数Long是可选的，整数，表示所允许的字符数。
        如果将MaxLength属性设置为0，表示只要内存允许则没有限制。

 

我看了你的第370楼中的EXCEL中的定时器，我把你的代码中的间隔时间改为3秒以上按停止按钮就不起效了，是怎么回事？应如何实现可以间隔3秒以上呢？
是有这问题，好像有时起效有时又不起效，具体原因未知。

此问题请袁版主帮忙解答，谢谢！
我在前面说过，对于API、SQL、类，只能说是一知半解，也正在学习这方面内容，以后有可能的话再和大家分享这方面的学习心得。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=19
本帖已被收录到知识树中，索引项：开发帮助和教程
很感谢你回答我的问题，我是想在excel中做一个按钮，使它根据鼠标离开、靠近、点击三种状态现出不同的产色的动态效果，希望各位老师能回答详细点，非常感谢。

试试利用按钮的MouseMove事件和Click事件中设置BackColor属性。

版主，用条件格式设置单元格时只能有三层，能不能用VBA突破这个限制，盼你的回音，谢谢！！！ Selection.FormatConditions.Delete Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLessEqual, ...
可以的，具体请上附件、发新贴提问。

PS：本贴不是问题回答贴，为了方便大家阅读，请有问题的朋友另外发贴，这样可能解决的速度更快些。

第8部分 控件与用户窗体
技巧104 将光标返回文本框中 在用文本框往工作表录入数据时，一般会在录入到工作表前验证输入的数据是否正确，如果错误，则清空文本框内容，提示用户重新输入。
但此时光标已经不在文本框中，需要重新选择文本框才能输入。
        可以在Exit事件中可以设置Cancel参数值使光标停留在当前文本框中，如下面的代码所示。

  Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
      With TextBox1
          If .Text <> "" And Len(Trim(.Text)) <> 15 And Len(Trim(.Text)) <> 18 Then
              .Text = ""
              MsgBox "身份证号码录入错误!"
              Cancel = True
          End If
      End With
  End Sub
       文本框的Exit事件，在输入身份证号码后即将把焦点转移到录入按钮控件之前检查输入的身份证号码是否正确。
        Exit事件在一个控件从同一窗体的另一个控件实际接收到焦点之前发生,语法如下:
Private Sub object_Exit( ByVal Cancel As MSForms.ReturnBoolean) Cancel参数为事件状态。
False表示由该控件处理这个事件（这是默认方式）。
True表示由应用程序处理这个事件，并且焦点应当留在当前控件上。
        第3行代码，使用Len函数和Trim函数检查输入的身份证号码是否为15位或18位。
        第4行到第6行代码，如果输入的身份证号码不正确，清空文本框以便重新输入并提示用户，设置Cancel参数为True使光标停留在文本框中。
        在Exit事件中之所以把文本框为空也做为通过验证的条件之一，因为如果不加上“TextBox1.Text <> ""”这一条件，那么在窗体显示后，如果用户取消输入或关闭输入窗体，也会提示输入错误。
所以在录入到工作表之前再验证文本框是否为空，如下面的代码所示。

  Private Sub CommandButton1_Click()
      With TextBox1
          If .Text <> "" Then
              Sheet1.Range("a65536").End(xlUp).Offset(1, 0) = .Text
              .Text = ""
          Else
              MsgBox "请输入身份证号码!"
          End If
              .SetFocus
      End With
  End Sub
       输入按钮的Click事件，把文本框数据录入到工作表A列最后一个单元格中并重新选择文本框准备下一次输入。
        第3行代码，在输入到工作表前检查文本框是否为空。
        第4、5行代码，如果文本框不为空，录入数据到工作表并清空文本框内容。
        第7行代码，如果文本框为空，提示用户输入数据。
        第8行代码，使用SetFocus方法将光标返回到文本框中以便重新输入。
        SetFocus方法将焦点移动到对象的实例中，语法如下 ：
object.SetFocus 参数object.是必需的，一个有效的对象。
        运行窗体，在输入框中输入身份证号码后自动验证输入的数据，如果输入数据错误，清空文本框并提示用户重新输入，如图所示。

 

第8部分 控件与用户窗体
技巧105 文本框的自动换行 在使用使用文本框显示或录入一段很长的文本时，需要将文本框设置成多行显示，否则文本内容只能在一行中显示，示例代码如下：
  Private Sub UserForm_Initialize()
      With TextBox1
          .WordWrap = True
          .MultiLine = True
          .Text = Space(4) & "VBA(Visual Basic for Application)是" _
                  & "微软公司为了加强Office软件的二次开发能力而附加" _
                  & "于其中的编程语言。
VBA的确非常强大，其与VB完全一" _
                  & "致的语法结构，高效控制Office对象模型的能力，令无" _
                  & "数人为之折腰。
利用VBA，几乎可以在Office里面做任何" _
                  & "其他程序能做的事情。
但是，应该清楚的认识到VBA是依" _
                  & "托其宿主─—Excel（或其他Office组件）而存在的，对" _
                  & "于Excel用户来讲，VBA只不过是锦上添花的东西，切不可" _
                  & "本末倒置，捡了芝麻丢了西瓜，把明明能够利用Excel内置" _
                  & "功能完成的任务，硬是搬到VBA里面去做，以为用代码实现" _
                  & "就是高人一头的表现。
其实，真正的高手，会尽量发挥" _
                  & "Excel自身的威力，不到万不得已的时候是不会去<Alt+F11>的。
"
      End With
  End Sub
       窗体的Initialize事件过程，在窗体显示时将文本框设置成多行显示文本。
        第3行代码设置文本框的WordWrap属性。
WordWrap属性指定一个控件的内容在行末是否自动换行，语法如下：
object.WordWrap [= Boolean] 参数object是必需的，一个有效的对象。
        参数Boolean是可选的，控件是否扩展以适应文本的大小，设置为True，文本换行，设置为False，文本不换行。
        第4行代码设置文本框的MultiLine属性。
MultiLine属性规定控件能否接受和显示多行文本，语法如下：
object.MultiLine [= Boolean] 参数object是必需的，一个有效的对象。
        参数Boolean是可选的，控件是否支持多行文本，设置为True，以多行显示文本，设置为False，不多行显示文本。
如果将多行文本框的MultiLine属性设置为False，则文本框的所有字符都将合并为一行，包括非打印字符（如，回车和换行）。
        对于既支持WordWrap属性又支持MultiLine属性的控件，当MultiLine属性为False时，WordWrap属性被忽略。
        运行窗体，文本框显示如图所示。

 

3

吃撑De三文鱼
征婚启事
jiangdong110
第8部分 控件与用户窗体
技巧106 多个文本框数据相加 在技巧102 中，我们在TextBox1、TextBox2中输入完数据后，利用文本框的Change事件使TextBox3显示其两者相乘的金额，但是如果窗体中有多个文本框，需要在每一个文本框的Change事件中写上相同的重复代码，因此使用类模块可以简化代码。
        在附件的窗体有七个文本框，其中六个用来输入数据，一个用来显示其他六个文本框相加后的合计数，首先打开VBE，插入一个类模块建立一个类，类模块的名字就是类的名字修改为“cmds”，在类模块中输入下面的代码：
Public WithEvents cmd As MSForms.TextBox 代码解析： 使用Public语句声明变量cmd是用来响应由TextBox对象触发的事件的对象变量。
        在窗体的Initialize事件中写入下面的代码：
  Dim col As New Collection
  Private Sub UserForm_Initialize()
      Dim i As Integer
      Dim myc As cmds
      For i = 1 To 6
          Set myc = New cmds
          Set myc.cmd = Me.Controls("TextBox" & i)
          col.Add myc
      Next
      Set myc = Nothing
  End Sub
       第1行代码在模块顶部声明变量col的类型为集合。
        第5行到第9行代码，将窗体中的六个文本框赋给col集合。

（关于类模块请参阅论坛中有关的资料。
） 在类模块中写入下面的代码：
  Private Sub cmd_Change()
      Dim i As Integer
      Dim Dval As Double
      For i = 1 To 6
          Dval = Dval + Val(UserForm1.Controls("TextBox" & i))
          UserForm1.TextBox7.Value = Dval
      Next
  End Sub
       窗体中的六个文本框统一的Change事件，当任何一个文本框中的数据发生变化时，所有文本框相加的合计数显示在最后一个文本框中。
 运行窗体在文本框中输入数据结果如图所示。

第8部分 控件与用户窗体
技巧107 控件跟随活动单元格 在工作表中使用控件时一般都把控件放在工作表的上部，如果工作表中数据较多，当页面滚动到工作表下面的区域时，控件会离开当前可视区域，这时操作起来很不方便。
解决方法除了冻结工作表的第一行放置控件的外，还可以使控件出现在选定的单元格位置，如下面的代码所示。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      With Me.CommandButton1
          .Top = Target.Top
          .Left = Target.Left + Target.Width
      End With
  End Sub
       工作表的SelectionChange事件，使工作表中的按钮控件出现在选定单元格的右边。
        第3行代码，设置按钮的Top属性等于选定单元格的Top属性。
Top属性设置对象顶端到第一行顶端的距离。
        第4行代码，设置按钮的Left属性等于选定单元格的Left属性加上选定单元格的宽度，即按钮出现在选定单元格的右边。
Left属性设置对象左边界至 A 列左边界的距离。
        当单击工作表区域的任一单元格，按钮出现在单元格的右边，如图所示。

第8部分 控件与用户窗体
技巧108 高亮显示按钮 为了达到当鼠标掠过按钮时以高亮和凸起显示按钮的效果，可以在窗体和按钮的MouseMove事件中进行模拟，如下面的代码所示。

  Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
      With Me.CommandButton1
          .BackColor = &HFFFF00
          .Width = 62
          .Height = 62
          .Top = 69
          .Left = 31
      End With
  End Sub
  Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
      With Me.CommandButton1
          .BackColor = Me.BackColor
          .Width = 60
          .Height = 60
          .Top = 70
          .Left = 32
      End With
  End Sub
     窗体和按钮的MouseMove事件过程，以高亮和凸起显示按钮。
      当用户在窗体中移动鼠标时，分别在窗体和按钮的MouseMove事件设置按钮的BackColor属性值，指定按钮的背景色，当鼠标移动到按钮时以高亮显示，当鼠标移动到窗体时恢复原来的设置。
接下来分别设置按钮不同的Width属性、Height属性、Top属性和Left属性值，以模拟按钮凸起的效果。
 运行窗体，当鼠标掠过按钮时效果如图所示。

第8部分 控件与用户窗体
技巧109 组合框和列表框添加列表项的方法 组合框和列表框是Excel中最常用的控件，可以用来显示工作表中的数据。
为组合框和列表框添加列表项的方法有多种，下面以列表框为例演示添加列表项的方法。

109-1 使用RowSource属性添加列表项

使用RowSource属性将列表框直接与工作表上的一个单元格区域相链接，如下面的代码所示。

  Private Sub UserForm_Initialize()
      Dim iRow As Integer
      iRow = Sheet1.Range("A65536").End(xlUp).Row
      Me.ListBox1.RowSource = "sheet1!a1:a" & iRow
  End Sub
      在窗体初始化时使用RowSource属性为列表框添加列表项。
        RowSource属性的语法如下：
object.RowSource [= String] 参数object是必需的，一个有效的对象。
        参数String是可选的，组合框或列表框列表的来源。
        RowSource属性也可以使用单元格地址，第4行代码可以改成下面的代码：
Me.ListBox1.RowSource = Sheet1.Range("A1:A" & iRow).Address(External:=True) 需要注意的是，如果RowSource属性指定的工作表区域不是活动工作表的话，Address属性的External参数是不可缺的，设置为True表示是外部引用，如果缺省此参数或为False，将不能为列表框添加列表项。
        RowSource属性还可以使用命名的单元格区域，如果已把工作表区域命名为“城市”，第4行代码可以改成下面的代码：
Me.ListBox1.RowSource = "城市" 对于工作表中的列表框控件或使用窗体添加的列表框控件不能使用RowSource属性，需要使用ListFillRange属性指定填充列表框的工作表区域，如下面的代码所示。

  Sub ListFillRange()
      Dim iRow As Integer
      iRow = Sheet1.Range("A65536").End(xlUp).Row
      Sheet2.ListBox1.ListFillRange = "Sheet1!a1:a" & iRow
      Sheet2.Shapes("列表框").ControlFormat.ListFillRange = "Sheet1!a1:a" & iRow
  End Sub
       ListFillRange过程为工作表中的列表框的填充区域，ListFillRange属性用于指定填充列表框的工作表区域。
        对于使用窗体添加的列表框控件需要使用ControlFormat属性来返回窗体控件以后才能设置其ListFillRange属性。

第8部分 控件与用户窗体
技巧109 组合框和列表框添加列表项的方法

109-2 使用List属性添加列表项

使用List属性为列表框添加列表项，如下面的代码所示。

  Private Sub UserForm_Initialize()
      Dim Arr As Variant
      Dim iRow As Integer
      iRow = Sheet1.Range("A65536").End(xlUp).Row
      Arr = Sheet1.Range("A1:A" & iRow)
      Me.ListBox1.List = Arr
  End Sub
       在窗体初始化时使用List属性为列表框添加列表项。
        List属性的语法如下：
object.List( row, column ) [= Variant] 参数object是必需的，一个有效对象。
        参数row是必需的，取值范围为 0 到列表条目数减 1 之间的数值。
        参数column是必需的，取值范围为 0 到总列数减 1 之间的数值。
        参数Variant是可选的，列表框中指定条目的内容。
        第6行代码，使用List属性把数组复制到列表框控件上。
        除了使用数组外，List属性还可以使用命名的单元格区域，如果已把工作表区域命名为“城市”，可以改成下面的代码：
  Private Sub UserForm_Initialize()
      Me.ComboBox1.List = Range("城市").Value
  End Sub

  Sub List()
      Dim Arr As Variant
      Dim iRow As Integer
      Dim myObj As Object
      iRow = Sheet1.Range("A65536").End(xlUp).Row
      Arr = Sheet1.Range("A1:A" & iRow)
      Set myObj = Sheet2.Shapes("列表框 10").ControlFormat
      myObj.List = Arr
  End Sub
       List过程设置列表框的List性，用于指定填充列表框的工作表区域。

 

第8部分 控件与用户窗体
技巧109 组合框和列表框添加列表项的方法

109-3 使用AddItem方法添加列表项

使用AddItem方法添加列表项，对于单列的列表框，在列表中添加一项。
对于多列的列表框，在列表中添加一行，如下面的代码所示。

  Private Sub UserForm_Initialize()
      Dim iRow As Integer
      Dim i As Integer
      iRow = Sheet1.Range("A65536").End(xlUp).Row
      For i = 1 To iRow
          Me.ListBox1.AddItem (Sheet1.Cells(i, 1))
      Next
  End Sub
       在窗体初始化时使用AddItem方法为列表框添加列表项。
        AddItem方法的语法如下：
object.AddItem [ item [, varIndex]] 参数object是必需的，一个有效的对象。
        参数item是可选的，指定要添加的项或行。
第一个项或行的编号为 0；第二个项或行的编号为 1，依此类推。
        参数varIndex是可选的，指定新的项或行在对象中的位置。
        如果提供一个有效的varIndex的值，AddItem方法就把项或行放在列表中的那个位置。
如果忽略 varIndex，此方法就把项或行添加在列表的末尾。
对于多列列表框或者组合框，AddItem 方法插入一个完整的行，为控件的每一列都插入一项。
为了给第一列后面的项赋值，可用List或Column属性来规定项的行和列。
        对于工作表中使用窗体添加的列表框控件使用AddItem方法添加列表项，如下面的代码所示。

  Sub AddItem()
      Dim iRow As Integer
      Dim i As Integer
      iRow = Sheet1.Range("A65536").End(xlUp).Row
      With Sheet2.Shapes("列表框").ControlFormat
          .RemoveAllItems
          For i = 1 To iRow
              .AddItem Sheet1.Cells(i, 1)
          Next
      End With
  End Sub
       AddItem过程设置使用AddItem方法添加为工作表中使用窗体控件添加的列表框添加列表项。
        其中第5行代码使用ControlFormat属性来返回窗体控件，第6行代码使用RemoveAllItems方法删除窗体控件中的列表框的所有数据项，如果控件是ActiveX 列表框则需要使用Clear方法。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=20
第8部分 控件与用户窗体
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧110 去除列表框数据源的重复值和空格 列表框的数据源引用工作表的数据时，如果工作表数据有重复值和空格，列表框也会出现重复值和空格，如图所示。

       为了在窗体显示时去除列表框的重复值和空格，可以使用Add方法，如下面的代码所示。

  Private Sub UserForm_Initialize()
      On Error Resume Next
      Dim Col As New Collection
      Dim rng As Range, arr
      Dim i As Integer
      For Each rng In Range("A1:A" & [a65536].End(xlUp).Row)
          If Trim(rng) <> "" Then
              Col.Add rng, key:=CStr(rng)
          End If
      Next
      ReDim arr(1 To Col.Count)
      For i = 1 To Col.Count
          arr(i) = Col(i)
      Next
      Me.ListBox1.List = arr
  End Sub
       窗体的初始化事件，去除列表框引用工作表数据中的重复值和空格。
        第2行代码，错误处理语句，忽略错误。
        第3行到第5行代码，声明变量类型。
        第6行到第9行代码代码，在列表框引用的工作表数据中循环，把工作表数据源中的空格去除后使用Add方法添加到变量Col中。
Add方法添加一个成员到Collection 对象，语法如下：
object.Add item, key, before, after 参数object是必需的，一个有效的对象。
        参数Item是必需的，任意类型的表达式，指定要添加到集合中的成员。
        参数Key是可选的，唯一字符串表达式，指定可以使用的键字符串，代替位置索引来访问集合中的成员。
        如果指定的key和集合中现有成员的key发生重复，则会导致错误发生。
所以在第2行代码中使用错误处理语句，忽略错误，继续执行下一句代码，这样就将数据源中的重复值去除。
        参数before是可选的，指定集合中的相对位置。
在集合中将添加的成员放置在before参数识别的成员之前。
如果参数是数值表达式，则before必须是介于 1 和集合Count属性值之间的值。
如果参数是字符串表达式，则当添加一个被引用的成员到集合时，before 必须对应于指定的key值。
可以指定before位置或after位置，但不能同时指定这两个位置。
        参数after是可选的，指定集合中的相对位置。
在集合中将添加的成员放置在After参数识别的成员之后。
如果参数是数值表达式，则after必须是介于 1 和集合Count属性值之间的值；如果参数是字符串表达式，则当添加一个被引用的成员到集合时，after 必须对应于指定的key值。
可以指定before位置或after位置，但不能同时指定这两个位置。
        第10行到第14行代码，重新定义数组arr大小，把Col中数据赋给数组。
        第15行代码，把数组arr复制到列表框中。
        运行窗体，窗体中的列表框引用去除重复值和空格后的工作表数据，如图所示。

技巧111 移动列表框条目 将列表框中的条目进行上下移动，如下面的代码所示。

  Dim Intlist As Integer
  Dim Strlist As String
  Private Sub CommandButton1_Click()
      With Me.ListBox1
          Intlist = .ListIndex
          Select Case Intlist
              Case -1
                  MsgBox "请选择一行后再移动!"
              Case 0
                  MsgBox "已经是最上一行了!"
              Case Is > 0
                  Strlist = .List(Intlist)
                  .List(Intlist) = .List(Intlist - 1)
                  .List(Intlist - 1) = Strlist
                  .ListIndex = Intlist - 1
          End Select
      End With
  End Sub
  Private Sub CommandButton2_Click()
      With ListBox1
          Intlist = .ListIndex
          Select Case Intlist
              Case -1
                  MsgBox "请选择一行后再移动!"
              Case .ListCount - 1
                  MsgBox "已经是最下一行了!"
              Case Is < .ListCount - 1
                  Strlist = .List(Intlist)
                  .List(Intlist) = .List(Intlist + 1)
                  .List(Intlist + 1) = Strlist
                  .ListIndex = Intlist + 1
          End Select
      End With
  End Sub
       第1、2行代码在模块顶部声明两个变量分别用于保存列表框当前选中行的索引和内容。
        第3行到第18行代码，将列表框当前选中行的内容上移一行的代码。
其中第5行代码使用变量Intlist保存列表框当前选中行的索引号，第6行代码判断索引号,，第7、8行代码如果变量Intlist值为-1 ，说明当前没有选中的行，显示一个消息框进行提示。
第9、10行代码变量Intlist值为0 ，说明当前选中的行已是第一行了。
        列表框的ListIndex属性指定当前选中的列表框或组合框条目，语法如下：
object.ListIndex [= Variant] 参数object是必需的，一个有效的对象。
        参数Variant是可选的，控件中当前被选的条目。
        第11行到第15行代码将当前选中的行向下移动一行，其中第12行代码将当前选中的行的内容赋给变量Strlist，第13行代码将当前选中行的内容更改为下面一行的内容，第14行代码将当前选中行的下面一行的内容更改为变量Strlist保存的内容，第15行代码将选中行向下移动一行，这样就将当前选中的行向下移动了一行。
        第19行到第34行代码将当前选中的行向上移动一行。
        将移动后的列表框条目保存到工作表中的代码如下：
  Private Sub CommandButton3_Click()
      Dim i As Integer
      For i = 1 To ListBox1.ListCount
          Sheet1.Cells(i + 1, 1) = ListBox1.List(i - 1)
      Next
  End Sub
       窗体中“保存”按钮的单击过程，将移动后的列表框条目保存到工作表。
        第3行到第5行代码使用For...Next 语句循环遍历列表框所有条目，将List属性返回的列表框的列表条目写入到工作表中。
List属性返回或设置列表框或组合框的列表条目数，语法请参阅技巧109-2。
        运行窗体效果如所示。

 

1

征婚启事
第8部分 控件与用户窗体
技巧112 允许多项选择的列表框 一般情况下在显示的列表框中用户只能选择一个列表项，而经过简单的设置，列表框条目前可以显示选项按钮，允许进行多项选择，如下面的代码所示。

  Private Sub UserForm_Initialize()
      Dim arr As Variant
      arr = Array("经理室", "办公室", "生技科", "财务科", "营业部", "制水车间", "污水厂", "安装公司", "其他")
      With Me.ListBox1
          .List = arr
          .ListStyle = 1
          .MultiSelect = 1
      End With
  End Sub
       窗体的Initialize事件过程，在窗体初始化时对列表框进行设置。
        其中第5行代码使用List属性为列表框添加列表项，请参阅技巧109-2。
        第6行代码将列表框的ListStyle属性设置为1（fmListStyleOption），显示用于多重选择列表的复选框，ListStyle属性规定列表框或组合框中的列表的外观，语法如下：
object.ListStyle [= fmListStyle] 参数object是必需的，一个有效的对象。
        参数fmListStyle是可选的，列表的可视风格，设置值如表格所示。

       ListStyle 属性可用来改变列表框或组合框的可视外观。
通过一种不同于 fmListStylePlain 的设置，可以将任意控件的内容作为一组单独项目演示，每个项目都包含一个可视记号用以表示它是否被选中。
        如果控件支持单一选择（MultiSelect属性被设置为mMultiSelectSingle），则可按下组中的一个按钮。
如果控件支持多重选择，则可以按下组中两个或更多的按钮。
        第7行代码将MultiSelect属性设置为1（fmMultiSelectMulti），允许列表框进行多项选择，MultiSelect属性表示对象是否允许多项选择，语法如下：
object.MultiSelect [= fmMultiSelect] 参数object是必需的，一个有效的对象。
        参数fmMultiSelect是可选的，控件所用的选择方式，设置值如表格所示。

       经过以上设置，列表框显示时可以进行多项选择并且条目前都有一个选项按钮用以表示它是否被选中，如图所示。

       如果将列表框的ListStyle属性设置为0则与常规的列表框相似。
        如果将列表框的MultiSelect属性设置0则列表框只能进行单项选择，如图所示。

       通过列表框的Selected属性值可以判断列表框中条目的选定状态，如下面的代码所示。

  Private Sub CommandButton1_Click()
      Dim i As Integer
      Dim s As String
      For i = 0 To ListBox1.ListCount - 1
          If ListBox1.Selected(i) = True Then
              s = s & ListBox1.List(i) & Chr(13)
          End If
      Next
      If s <> "" Then
          MsgBox "你选择了：" & Chr(13) & s
      Else
          MsgBox "请最少选择一个部门!"
      End If
  End Sub
       按钮的单击过程，将列表框中选中的条目使用消息框显示出来。
        第4行到第8行代码使用For...Next 语句循环遍历列表框所有条目，通过返回的Selected属性值判断列表框中条目的选定状态，如果处于选中状态，第6行代码将列表框选中条目的值赋给字符串变量s。
        Selected属性判断列表框中条目的选定状态，语法如下：
object.Selected( index ) [= Boolean] 参数object是必需的，一个有效的对象。
        参数index是必需的，整数，取值范围是0到列表中的条目数减1之间的数值。
        参数Boolean是必需的，判断一个条目是否被选中。
        第9行到第13行代码使用消息框显示列表框中选中的条目。
        运行窗体结果如图所示。

 

第8部分 控件与用户窗体
技巧113 多列组合框和列表框的设置

113-1 多列组合框和列表框添加列表项

如果组合框和列表框是多列的话，除了使用技巧109 的方法外，还需要设置控件的其他属性，如下面的代码所示。

  Private Sub UserForm_Initialize()
      Dim iRow As Integer
      Dim Arr As Variant
      iRow = Sheet1.Range("A65536").End(xlUp).Row
      Arr = Sheet1.Range("A1:G" & iRow)
      With Me.ListBox1
          .ColumnCount = 7
          .ColumnWidths = "45,45,45,45,45,30,45"
          .BoundColumn = 1
          .Column = Application.WorksheetFunction.Transpose(Arr)
      End With
  End Sub
       在窗体初始化时为多列列表框添加列表项。
        第4行代码，设置列表框显示的列数。
ColumnCount 属性指定列表框或组合框的显示列数，语法如下：
object.ColumnCount [= Long] 参数object是必需的，一个有效的对象。
        参数Long是可选的，指定需显示的列数。
        如果将ColumnCount设为 -1，将显示所有列。
        第8行代码，设置列表框各列的宽度。
ColumnWidths 属性指定多列的组合框或列表框中的各列的宽度，语法如下：
object.ColumnWidths [= String] 参数object是必需的，一个有效的对象。
        参数String是可选的，以磅为单位设置列的宽度。
        如将ColumnWidths 属性设为 -1 或空，则将控件宽度等分，给予列表中的各列。
设为 0 则隐藏该列，大于 0 的数值则是该列的精确宽度值。
若要指定另一种不同的度量单位，设置时必须包括该度量单位。
        第9行代码，设置多列列表框中的第一列为数据的来源。
BoundColumn 属性标识多列组合框或列表框中的数据的来源，语法如下：
object.BoundColumn [= Variant] 参数object是必需的，一个有效的对象。
        参数Variant是可选的，标识选择 BoundColumn 属性值的方法，设置值如表格所示：
       当选择了多列列表框的一行时，BoundColumn 属性标识出将该行的哪一条目作为控件的值存储。
BoundColumn属性设为 0，将所选行的行号赋予控件，作为控件的值。
如果BoundColumn属性设为1 或者大于 1，则将指定列中的值赋予控件。
        第10行代码，设置多列列表框中列表的来源。
在设置列表来源时除了可以使用技巧109 所介绍的方法外，还可以使用Column属性指定列表框中的一个或多个条目，Column属性语法如下：
object.Column( column, row ) [= Variant] 参数object是必需的，一个有效对象。
        参数column是可选的，取值范围为0到总列数减1之间的数值。
        参数row是可选的，取值范围为0到总行数减1之间的数值。
        参数Variant是可选的，指定欲加载到列表框的一个值、一列值或一个二维数组。

注意 当从一个二维数组中复制数据时，使用Column属性将转置控件中数组的内容，所以在加载时需使用Transpose函数对数组进行转置。
        多列列表框设置完成后效果如图所示。

第8部分 控件与用户窗体
技巧113 多列组合框和列表框的设置

113-2 多列列表框写入工作表

在把多列列表框的写入工作表中时，只能把BoundColumn属性所指定列中的值写入工作表中，不能把选中的整行内容写入到工作表中。
如果需要把多列列表框中选中行的整行内容写入工作表中，可以使用循环语句将列表框各列的写入工作表，如下面的代码所示。

  Private Sub UserForm_Initialize()
      Dim iRow As Integer
      iRow = Sheet2.Range("A65536").End(xlUp).Row
      With Me.ListBox1
          .ColumnCount = 7
          .ColumnWidths = "45,45,45,45,45,30,45"
          .BoundColumn = 1
          .ColumnHeads = True
          .RowSource = Sheet2.Range("A2:G" & iRow).Address(External:=True)
      End With
  End Sub
  Private Sub ListBox1_Click()
      Dim iRow As Integer
      Dim i As Byte
      iRow = Sheet1.Range("A65536").End(xlUp).Row + 1
      For i = 1 To ListBox1.ColumnCount
          Sheet1.Cells(iRow, i) = ListBox1.Column(i - 1)
      Next
  End Sub
       第1行到第11行代码窗体的Initialize事件过程，在窗体初始化时为多列列表框添加列表项，请参阅技巧113-1。
        第8行代码，设置多列列表框中的第一行为列标题行。
ColumnHeads 属性显示列表框、组合框及接受列题注的对象中的列标题行，语法如下：
object.ColumnHeads [= Boolean] 参数object是必需的，一个有效的对象。
        参数Boolean是可选的，指定是否显示列标题。
        将ColumnHeads 属性设置为True，多列列表框的第一行显示为列标题，默认值为False，不显示列标题。
        需要注意的是，当数据项中的第一行作为列标题时，则不可选中该行。
        第9行代码，使用RowSource属性设置多列列表框中列表的来源。
关于RowSource属性请参阅技巧109-1。

注意 如果已将多列列表框中列表项来源的第一行设置为列标题，在设置RowSource属性时应从列表项来源的第二行开始设置。
        第12行到第19行代码列表框的Click事件，单击多列列表框时把选中行的整行内容写入工作表中。
其中第17行代码，使用循环语句将多列列表框选中行的各列的值写入工作表对应的单元格中。
关于Column属性请参阅技巧113-1，在本例中没有指定row参数，所以是把当前选中行的内容写入工作表。
        运行窗体后，单击列表框将选中的整行内容写入工作表中，如图所示。

建议能否搞一个打包下载的更方便吧！谢谢！
已完成部分有打包下载的，请到2楼以下找链接。

点击每楼右边的楼层复制，如407楼http://club.excelhome.net/viewth ... ;page=41#pid2606490
多谢tkgg93，原来是这样的，等有空了我重新做一下楼层链接。

43-2 错误处理方法

使用错误处理程序判断指定名称的工作簿是否打开，如下面的代码所示。
复制内容到剪贴板代码: Set Wb = Nothing 语句的作用是什么？
销毁对象，将对象变量从实际对象中分离开来，释放与被引用的对象有关联的内存资源及系统资源。

第8部分 控件与用户窗体
技巧114 输入时逐步提示信息 用户在录入数据时，比如在工作表中输入产品名称，除了希望有所有产品名称的下拉列表供选择外，更希望能逐步给出提示信息。
比如在输入一两个字符后把符合条件的数据筛选出来供选择，最好是中英文、拼音首字母、大小写能混合查询，如输入“LJ”或“六角”后所有以“六角”开头的产品名称都筛选到列表中供选择，这将大大提高录入速度和正确率。
 为了达到这一目的，首先在工作簿需要有如图所示的基础数据表。

       基础数据表中A列保存不重复的产品名称，为了能用中英文、拼音首字母、大小写混合查询，要把产品名称转换成小写的拼音首字母保存在B列。
        步骤1：在VBE窗口单击菜单“插入”→“模块”，在代码窗口写入下面的代码。

  Public Function LChin(Str As String) As Variant
      On Error Resume Next
      Str = StrConv(Str, vbNarrow)
      If Asc(Str) > 0 Or Err.Number = 1004 Then LChin = ""
      LChin = WorksheetFunction.VLookup(Str, [{"吖","a";"八","b";"嚓","c";"咑","d";"鵽","e";"发","f";"猤","g";"铪","h";"夻","j";"咔","k";"垃","l";"嘸","m";"旀","n";"噢","o";"妑","p";"七","q";"囕","r";"仨","s";"他","t";"屲","w";"夕","x";"丫","y";"帀","z"}], 2)
  End Function
       自定义LChin函数，该函数把中文字符转换为拼音首字母。
        步骤2：在VBE窗口双击Sheet2表，在代码窗口写入下面的代码。

  Private Sub Worksheet_Change(ByVal Target As Range)
      Dim i As Integer
      Dim myStr As String
      With Target
          If .Column <> 1 Or .Count > 1 Then Exit Sub
          If WorksheetFunction.CountIf(Sheet2.Range("A:A"), .Value) > 1 Then
              .Value = ""
              MsgBox "不能输入重复的产品名称!", 64
              Exit Sub
          End If
          For i = 1 To Len(.Value)
              If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
                  myStr = myStr & LChin(Mid$(.Value, i, 1))
              Else
                  myStr = myStr & LCase(Mid$(.Value, i, 1))
              End If
          Next
          .Offset(, 1).Value = myStr
      End With
   End Sub
       工作表的Change事件，当A列输入不重复的产品名称后，转换成小写的字母保存在B列的单元格中，便于以后的查询。
        第11行代码，设置事件触发的条件，只有在A列输入产品名称后才触发Change事件。
         第12行到第16行代码，使用工作表CountIf函数检查输入的产品名称是否重复。
        第17行到第23行代码，字符的转换过程。
首先检查是否是中文字符，如果是使用自定义函数LChin转换成小写拼音首字母。
如果是大写的英文字母使用LCase函数转换成小写字母。
        第24行代码，将转换后的字符保存到B列。
        步骤3：基础数据表完成后，在工作表“录入表”中添加一个文本框控件和一个列表框控件。
在VBE窗口中双击Sheet1表，写入下面的代码。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Dim i As Integer
      If Target.Count = 1 Then
          If Target.Column = 1 And Target.Row > 1 Then
              With Me.TextBox1
                  .Visible = True
                  .Top = Target.Top
                  .Left = Target.Left
                  .Width = Target.Width
                  .Height = Target.Height
                  .Activate
              End With
              With Me.ListBox1
                  .Visible = True
                  .Top = Target.Top
                  .Left = Target.Left + Target.Width
                  .Width = Target.Width
                  .Height = Target.Height * 5
                  For i = 2 To Sheet2.Range("A65536").End(xlUp).Row
                      .AddItem Sheet2.Cells(i, 1).Value
                  Next
              End With
          Else
              Me.ListBox1.Clear
              Me.TextBox1 = ""
              Me.ListBox1.Visible = False
              Me.TextBox1.Visible = False
          End If
      End If
  End Sub
       工作表的SelectionChange事件，当用户选定工作表A列第2行以下的单个单元格时，设置文本框和列表框的Visible为True，使它们成为可见的，并设置其外观，同时给列表框加载列表项。
当用户选定其他列的单元格时隐藏文本框和列表框控件。
        步骤4：在设计模式下双击文本框，在代码窗口写入下面的代码。

  Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      Dim i As Integer
      Dim Language As Boolean
      Dim myStr As String
      Me.ListBox1.Clear
      With Me.TextBox1
          For i = 1 To Len(.Value)
              If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
                  Language = True
                  myStr = myStr & Mid$(.Value, i, 1)
              Else
                  myStr = myStr & LCase(Mid$(.Value, i, 1))
              End If
          Next
      End With
      With Sheet2
          For i = 2 To .Range("A65536").End(xlUp).Row
              If Language = True Then
                  If Left(.Cells(i, 1).Value, Len(myStr)) = myStr Then
                      Me.ListBox1.AddItem .Cells(i, 1).Value
                  End If
              Else
                  If Left(.Cells(i, 2).Value, Len(myStr)) = myStr Then
                      Me.ListBox1.AddItem .Cells(i, 1).Value
                  End If
              End If
          Next
      End With
  End Sub
       文本框的KeyUp事件，在文本框输入查询条件时筛选符合条件的数据加载到列表框。
        第3行代码，声明变量Language为Boolean数据类型，在下面的代码中使用Language的值判断输入的是否为中文。
        第5行代码，使用Clear方法删除列表框所有的列表项，语法如下：
object.Clear 参数object是必需的，一个有效的对象。
        注意，如果列表框绑定了数据，Clear方法将会失败。
        第6行到第15行代码，判断文本框输入的是否为中文字符。
如果是中文字符，将变量Language赋值为True，并把文本框中的字符赋给变量myStr。
如果是英文字符则转换成小写字母后赋变量myStr。
        第16行到第29行代码，如果变量Language的值为True，在基础数据表的A列中使用Left函数查找与文本框字符相符的单元格并加载到列表框，否则就在B列查找。
        步骤5：在设计模式下双击文本框，在代码窗口写入下面的代码。

  Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      If KeyCode = vbKeyReturn Then
          Sheet1.ListBox1.Activate
      End If
  End Sub
       文本框的KeyDown事件，当用户在文本框中输入完成，列表框中已显示所需的内容后按回车键后选择列表框。
        步骤6：在设计模式下双击列表框，在代码窗口写入下面的代码
  Private Sub ListBox1_GotFocus()
      On Error Resume Next
      ListBox1.ListIndex = 0
  End Sub
       列表框的GotFocus事件，当用户在文本框中输入完成按回车键后，选定列表框中第1个条目，方便用户进行下一步操作。

  Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      If KeyCode = vbKeyReturn Then
          ActiveCell.Value = ListBox1.Value
          Me.ListBox1.Clear
          Me.TextBox1 = ""
          Me.ListBox1.Visible = False
          Me.TextBox1.Visible = False
      End If
  End Sub
       列表框的KeyDown事件，当用户在列表框中按下回车后将列表框选中的条目写入到活动工作表的单元格中，同时清空文本框和列表框内容后隐藏，准备下一次录入。

  Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
      ActiveCell.Value = ListBox1.Value
      Me.ListBox1.Clear
      Me.TextBox1 = ""
      Me.ListBox1.Visible = False
      Me.TextBox1.Visible = False
  End Sub
       列表框的DblClick事件，当用户双击列表框的列表项时，把列表框数据赋给活动单元格，同时清空文本框和列表框内容后隐藏，准备下一次录入。
        以上设置完成后，在“录入”工作表的A列选定单元格后，显示一个文本框和一个列表框，在文本框中输入查询条件后列表框显示符合查询条件的所有内容供用户选择，如图所示。

 

1

莫愁湖

1-3 使用快捷记号

Sub Fastmark() [A1：A5] = 2 [Fast] = 4 End Sub
为什么运行上面的代码时会提示"要求对象"/?
应该怎样操作?
示例中的B1：B5单元格已命名为Fast，如果没有命名或命名不正确会提示"要求对象"。

第8部分 控件与用户窗体
技巧115 二级组合框 在使用多个组合框输入数据时，往往希望后一个组合框中的条目能根据前一个组合框的内容有所不同，如示例中第二个选择城市的组合框根据第一个选择省份的组合框所选择的不同省份加载不同的县市名称，示例代码如下：
  Private Sub UserForm_Initialize()
      Dim col As New Collection
      Dim arr As Variant
      Dim rng As Range
      Dim i As Integer
      On Error Resume Next
      For Each rng In Range("A2:A" & Sheet1.Range("A65536").End(xlUp).Row)
          If rng <> "" Then col.Add rng, CStr(rng)
      Next
      ReDim arr(1 To col.Count)
      For i = 1 To col.Count
          arr(i) = col(i)
      Next
      ComboBox1.List = arr
      ComboBox1.ListIndex = 0
      CommandButton1.Accelerator = "D"
  End Sub
  Private Sub ComboBox1_Change()
      Dim myAddress As String
      Dim rng As Range
      Dim mymsg As Integer
      ComboBox2.Clear
      With Sheet1.Range("A:A")
          Set rng = .Find(What:=ComboBox1.Text)
              If Not rng Is Nothing Then
                  myAddress = rng.Address
                  Do
                      ComboBox2.AddItem rng.Offset(, 1)
                      Set rng = .FindNext(rng)
                  Loop While Not rng Is Nothing And rng.Address <> myAddress
              End If
          End With
          ComboBox2.ListIndex = 0
  End Sub
       第1行到第17行代码窗体的Initialize事件过程，在窗体显示时将工作表A列中的省份名称去除重复后加载到组合框中。
        其中第7行到第13行代码把工作表A列中的省份名称使用Add方法去除重复后加载到组合框中，应用于Collection 对象的Add方法添加一个成员对象，请参阅技巧110 。
       第15行代码设置组合框的ListIndex属性为0，选中组合框的第一行条目。
ListIndex属性指定当前选中的列表框或组合框条目，语法如下：
object.ListIndex [= Variant] 参数Variant是可选的，控件中当前被选的条目。
        ListIndex 属性包含列表中被选行的索引，取值范围为 -1 到列表总行数减 1（即ListCount - 1）之间的数值。
当用户没有选中行时，ListIndex 返回 -1。
列表中第一行的 ListIndex值是0，第二行的ListIndex 值是1，依此类推。
        第16行代码设置窗体中按钮的Accelerator属性值。
Accelerator属性设置或检索控件的加速键，语法如下：
object.Accelerator [= String] 参数String是可选的，用作加速键的字符。
       先按住 Alt 再紧接着按加速键，会将焦点定位到该对象上，并初始化与该对象关联的一个或多个事件，也就是说窗体显示后按Alt+D组合键将会执行“关闭”按钮中的代码关闭窗体。
        第18行到第34行代码ComboBox1的Change事件过程，使用Find方法将所有属于ComboBox1所选择的省份的县市加载到ComboBox2中。
关于Find方法请参阅技巧5-1。
        窗体运行后效果如图所示。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=21
第8部分 控件与用户窗体
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧116 使用DTP控件输入日期 在工作表中输入日期可以使用日期时间控件（Microsoft Date and Time Picker Control 6.0，简称DTP控件）。
        在工作表中单击菜单“视图”→“工具栏”→“控件工具箱”，选择“其他控件”中的DTP控件如图所示，在工作表中添加一个DTP控件。

       在设计模式下双击DTP控件写入下面的代码：
  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      With Me.DTPicker1
          If Target.Count = 1 And Target.Column = 2 And (Not Target.Row = 1) Or Target.MergeCells Then
              .Visible = True
              .Top = Selection.Top
              .Left = Selection.Left
              .Height = Selection.Height
              .Width = Selection.Width
              If Target.Cells(1, 1) <> "" Then
                  .Value = Target.Cells(1, 1).Value
              Else
                  .Value = Date
              End If
          Else
              .Visible = False
          End If
      End With
  End Sub
  Private Sub DTPicker1_CloseUp()
      ActiveCell.Value = Me.DTPicker1.Value
      Me.DTPicker1.Visible = False
  End Sub
  Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Count = 1 And Target.Column = 2 Or Target.MergeCells Then
          If Target.Cells(1, 1).Value = "" Then
              DTPicker1.Visible = False
          End If
      End If
  End Sub
       第1行到第18行代码工作表的SelectionChange事件，当选择工作表的B列第2行以下的单个单元格时显示日期控件供用户选择日期。
        其中第3行代码设置显示日期控件的触发条件。
只有当用户选择B列第2行以下单元格且只能选择单个单元格时才显示日期控件，因为本例B列中存在合并单元格，所以需要加上Or Target.MergeCells这个条件，否则单击合并单元格不显示日期控件。
        第4行到第8行代码显示日期控件并设置日期控件的大小等于所选单元格的大小。
        第9行到第13行代码，如果单元格已经输入了日期，将单元格中的日期赋给日期控件，否则将当前日期赋给日期控件。
因为本例B列中存在合并单元格，而合并区域的值在该区域左上角的单元格中指定，所以用Target.Cells(1, 1) 指定合并单元格的值，否则代码会出错。
        第15行代码如果选择的是其他列则隐藏日期控件。
        第19行到第22行代码日期控件的CloseUp事件，将日期控件的值赋给活动单元格后隐藏日期控件。
        第23行到第29行代码工作表的Change事件，如果删除了B列单元格的日期则隐藏日期控件。
       当用户选择B列单元格时效果如图所示。

第8部分 控件与用户窗体
技巧117 使用RefEdit控件选择区域 在技巧76-2中介绍了如何使用InputBox方法获得所选单元格区域的地址，而使用RefEdit控件获得单元格区域的地址比使用InputBox方法更加方便，可以单击RefEdit控件中的按钮以折叠用户窗体，选定区域后再单击按钮展开用户窗体，示例代码如下：
  Private Sub CommandButton1_Click()
      Dim Rng As Range
      On Error GoTo line
      Set Rng = Range(RefEdit1.Value)
          Rng.Interior.ColorIndex = 15
          Unload UserForm1
          Exit Sub
  line:
      MsgBox "你选择的是非单元格区域!"
  End Sub
       用户窗体中按钮的单击事件过程，改变用户使用RefEdit控件所选择的单元格区域内部的颜色。
        第3行代码，错误处理语句。
因为如果用户输入或选定了错误的单元格区域地址，将显示一错误信息，如图所示，所以必需使用On Error GoTo语句来绕过错误。

       第4行代码，使用Set语句将用户选择的单元格区域赋给变量rng。
        第5行代码，改变用户所选单元格区域内部的颜色。

注意 不能在无模式用户窗体中使用RefEdit控件。
        窗体运行后，当用户在工作表中选择一个单元格区域后改变所选单元格区域内部的颜色，如图所示。

请问版主，我下载下来打开文件时，为什么会出现这样的错误！
这是因为DTP控件没有注册引用，请注意这几天的内容，会有关于如何注册引用控件方面的内容。

  Sub RangeCopy() Application.DisplayAlerts = False Sheet1.Range("A1").CurrentRegion.Copy Sheet2.Range("A1") Application.DisplayAlerts = True End Sub
在 ...
删除Application.DisplayAlerts = False这句代码。

第8部分 控件与用户窗体
技巧118 如何注册控件 Excel文件中如果有ActiveX控件如日期时间控件（Microsoft Date and Time Picker Control 6.0，简称DTP控件），在有些电脑上运行时会出现“无法装载这个对象，因为它不适于这台计算机”的提示，如图所示。
文件中的控件丢失，无法正常使用。

       这是因为DTP控件没有注册引起的，解决办法是在能运行该控件的电脑中复制DTP控件的文件到目标电脑中进行注册。
在VBE窗口中右键单击“工具箱”，选择“附加控件”，在“附加控件”对话框中选择DTP控件，对话框底部会显示控件的名称和文件所在的路径，如图所示。

       DTP控件的文件名为MSCOMCT2.OCX，在C盘的Windows\system32文件夹中，把该文件复制到目标电脑C盘的Windows\system32文件夹中，单击“开始”→“运行”，在“运行”对话框中键入“regsvr32 C:\Windows\system32\MSCOMCT2.OCX”，注册成功后会出现如图所示的对话框，DTP控件即能正常使用。

       在Excel中可以使用程序代码进行自动注册，代码如下：
  Sub regsvrs()
      Dim SouFile As String
      Dim DesFile As String
      On Error Resume Next
      SouFile = ThisWorkbook.Path & "\MSCOMCT2.OCX"
      DesFile = "c:\Windows\system32\MSCOMCT2.OCX"
      FileCopy SouFile, DesFile
      Shell "regsvr32 /s" & DesFile
      MsgBox "DTP控件已成功注册，现在可以使用了!"
  End Sub
       Regsvrs过程将保存在同一目录中的MSCOMCT2.OCX文件复制到电脑的文件夹中，使用Shell函数注册DTP控件。
 第4行代码，错误处理语句，用于忽略复制文件时可能出现的错误。
因为如果电脑文件夹中已存在MSCOMCT2.OCX文件，使用FileCopy方法复制时会发生错误，如图所示。

       第7行代码，使用FileCopy方法复制MSCOMCT2.OCX文件到电脑中。
        FileCopy方法的语法如下：
FileCopy source, destination 参数Source是必需的，字符串表达式，用来表示要被复制的文件名。
        参数destination是必需的，字符串表达式，用来指定要复制的目的文件名。
        第8行代码，使用Shell函数注册DTP控件。
        Shell函数执行一个可执行文件，语法如下：
Shell(pathname[,windowstyle]) 参数pathname是必需的，要执行的程序名，以及任何必需的参数或命令行变量，可能还包括目录或文件夹，以及驱动器。
        参数windowstyle是可选的，表示在程序运行时窗口的样式。
windowstyle参数值如表格所示。

       运行程序前应确保在工作簿同一目录中存在MSCOMCT2.OCX文件。
此代码相当于在“运行”对话框中键入“regsvr32 C:\ Windows\system32\MSCOMCT2.OCX”后进行注册，只是在“REGSVR32”后加上了s参数，使注册成功后不会出现提示对话框。
        可以使用程序代码卸载该控件，代码如下：
  Sub regsvru()
      Shell "REGSVR32 /u " & ThisWorkbook.Path & "\MSCOMCT2.OCX"
  End Sub
       Regsvru过程使用Shell函数注册DTP控件，在pathname参数“REGSVR32”后加上u参数，对DTP控件进行反注册。

第8部分 控件与用户窗体
技巧119 遍历控件的方法 如果窗体或工作表中的控件很多，在写代码时，如果是相同的代码，可以使用循环语句遍历控件，无需每个控件都写相同的代码，以减少代码量。

119-1 使用名称中的变量遍历控件

如果控件使用系统缺省名称，如“TextBox1”、“TextBox2”，前面是固定的字符串，后面是序号的，可以使用For...Next 语句循环遍历控件。
       对于窗体中的控件，如下面的代码所示。

  Private Sub CommandButton1_Click()
      Dim i As Integer
      For i = 1 To 3
          Me.Controls("TextBox" & i) = ""
      Next
  End Sub
    窗体按钮的单击事件，一次性清空窗体中三个文本框的内容。
        第4行代码，将窗体中三个文本框名称中的最后一个序号设成变量，在文本框中循环并清空其内容。
        对于工作表中的控件，如下面的代码所示。

  Private Sub CommandButton1_Click()
      Dim i As Integer
      For i = 1 To 4
          Me.OLEObjects("TextBox" & i).Object.Text = ""
      Next
  End Sub
       工作表中按钮的单击事件，在工作表中的三个文本框中循环，清空文本框的内容。
        第4行代码，将工作表中四个文本框名称中的最后一个序号设成变量，使用OLEObjects方法在工作表中的文本框中循环。
        OLEObjects方法返回图表或工作表上单个OLE对象（OLEObject）或所有OLE对象的集合（OLEObjects集合）的对象，语法如下：
expression.OLEObjects(Index) 参数expression是必需的，返回一个Chart 对象或Worksheet 对象。
        参数Index 是可选的，OLE对象的名称或编号。
        注意 控件的名称是指控件在属性窗口中的名称，如图所示。
如果控件的名称没有规律不适用此方法。

第8部分 控件与用户窗体
技巧119 遍历控件的方法

119-2 使用对象类型遍历控件

如果控件的名称没有规律，可以使用For Each...Next 语句循环遍历所有控件，使用TypeName函数返回控件的对象类型，根据控件的对象类型进行相应的操作。
        对于窗体中的控件，如下面的代码所示。

  Private Sub CommandButton1_Click()
      Dim Ctr As Control
      For Each Ctr In Me.Controls
          If TypeName(Ctr) = "TextBox" Then
              Ctr = ""
          End If
      Next
  End Sub
       按钮的单击事件，遍历所有控件并把所有文本框的内容清空。
        第2行代码，声明变量类型。
        第3行代码，使用For Each...Next 语句遍历窗体所有控件。
        第4行代码，使用TypeName 函数返回变量的对象类型。
        TypeName 函数返回一个字符串，提供有关变量的信息，语法如下：
TypeName(varname) 参数varname是必需的，它包含用户定义类型变量之外的任何变量。
        如果变量Ctr是文本框控件，无论该文本框的名称是否已经被修改，TypeName(Ctr)都会返回“TextBox”字符串。
        对于工作表中的控件，则使用下面的代码。

  Private Sub CommandButton1_Click()
      Dim Obj As OLEObject
      For Each Obj In Me.OLEObjects
          If TypeName(Obj.Object) = "TextBox" Then
              Obj.Object.Text = ""
          End If
      Next
  End Sub

第8部分 控件与用户窗体
技巧119 遍历控件的方法

119-3 使用程序标识符遍历控件

工作表中的ActiveX控件还可以根据控件的程序标识符找到相应的控件，如下面的代码所示。

  Private Sub CommandButton1_Click()
      Dim Obj As OLEObject
      For Each Obj In Me.OLEObjects
          If Obj.progID = "Forms.TextBox.1" Then
              Obj.Object.Text = ""
          End If
      Next
  End Sub
       工作表中按钮的单击事件，遍历工作表中的所有控件并把工作表中所有文本框的内容清空。
        第2行代码，声明变量类型。
        第3行代码，使用For Each...Next 语句遍历工作表中的所有控件。
        第4行代码，使用控件的ProgId 属性返回控件的程序标识符。
        ProgId 属性返回控件的程序标识符，语法如下：
expression.ProgId 参数expression是必需的，一个有效的对象。
        ActiveX 控件的程序标识符如表格所示。

       文本框控件返回的程序标识符是“Forms.TextBox.1”，此返回值并不受文本框控件名称的影响，所以根据工作表中控件的程序标识符可以找出全部文本框控件。

第8部分 控件与用户窗体
技巧119 遍历控件的方法

119-4 使用名称中的变量遍历图形

如果工作表中有多个图形，可以根据名称的序号使用For...Next 语句遍历图形，如下面的代码所示。

  Private Sub CommandButton1_Click()
      Dim i As Integer
      For i = 1 To 3
          Me.Shapes("文本框 " & i).TextFrame.Characters.Text = "TextBox" & i
      Next
  End Sub
       工作表中按钮的单击事件，在工作表中的三个图形文本框中依次写入“TextBox1”、“TextBox2”和“TextBox3”字符串。
        第3行到第5行代码，使用Shapes属性在工作表上的三个图形文本框中循环。
        Shapes属性返回Shapes对象，代表工作表或图形工作表上的所有图形，可以使用Shapes(index)（其中index是图形的名称或索引号）返回单个的Shape对象。
        返回单个的Shape对象后使用Characters 方法向图形文本框中添加字符。
Characters 方法的语法如下：
expression.Characters(Start, Length) 参数expression是必需的，返回一个指定文本框内Characters对象的表达式。
        参数Start是可选的，表示将要返回的第一个字符。
如果此参数设置为 1 或被忽略，则Characters方法会返回以第一个字符为起始字符的字符区域。
        参数Length是可选的，表示要返回的字符个数。
如果此参数被忽略，则Characters 方法会返回该字符串的剩余部分。

第8部分 控件与用户窗体
技巧119 遍历控件的方法

119-5 使用FormControlType属性遍历图形

如果工作表中的是窗体控件，可以使用For Each...Next语句遍历工作表中图形并根据其FormControlType属性返回特定的窗体控件，如下面的代码所示。

  Private Sub CommandButton2_Click()
      Dim myShape As Shape
      For Each myShape In Sheet4.Shapes
          If myShape.Type = msoFormControl Then
              If myShape.FormControlType = xlCheckBox Then
                  myShape.ControlFormat.Value = 1
              End If
          End If
      Next
  End Sub
       工作表中按钮的单击事件，清除工作表中所有的复选框。
        第2行代码声明变量myShape为图形对象。
        第3行代码使用For Each...Next语句遍历工作表中的图形。
        第4行代码根据图形的Type属性判断图形是否为窗体控件。
应用于Shape对象的Type属性返回或设置图形类型，窗体控件返回常量msoFormControl。
        第5行代码根据控件的FormControlType属性判断窗体控件是否为复选框控件。
FormControlType属性返回窗体控件的类型，可以为表格所示的XlFormControl常量之一。

       第6行代码使用ControlFormat属性返回工作表中的复选框，并将其他Value属性设置为1选中复选框，如果需要取消复选框只需将Value属性设置为-4146。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=22
第8部分 控件与用户窗体
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧120 使微调框最小变动量小于1 在用微调框调节数值时，默认的变动量只能设置成整数。
为了使微调框的变动量小于1，如每次的变动量为0.01，需要在代码中做必要的设置，如下面的代码所示。

  Private Sub UserForm_Initialize()
      With Me.SpinButton1
          .Max = 10000
          .Min = -10000
          .SmallChange = 1
          .Value = 0
          Me.TextBox1 = Format(.Value, "0.00")
      End With
  End Sub
  Private Sub SpinButton1_Change()
      Me.TextBox1 = Format(Me.SpinButton1 * 0.01, "0.00")
  End Sub
       使用微调框调节文本框的数值，每次的变动量为0.01。
        第1行代码到第9行代码，窗体的初始化事件，在窗体显示时对微调框控件进行必要的设置。
        第3、4行代码，设置微调框控件的Max、Min 属性。
Max、Min 属性规定滚动条或数值调节钮的 Value 属性可接收的最大值和最小值，语法如下：
object.Max [= Long] object.Min [= Long] 参数object是必需的，一个有效的对象。
        参数Long是可选的，指定Value属性的最大设置值或最小设置值。
        第5行代码，设置微调框控件的SmallChange属性为1。
SmallChange属性设定当用户单击滚动条或数值调节钮中的滚动箭头时发生的变动量，语法如下：
object.SmallChange [= Long] 参数object是必需的，一个有效的对象。
        参数Long是可选的，设定Value属性的变动量。
        SmallChange属性只能设置为整数。
        第6行代码，设置窗体显示时微调框控件的Value属性为0。
        第7行代码，使用Format函数将将文本框的初始值格式化为“0.00”。
关于Format函数请参阅技巧102 。
        第11行代码，微调框控件的Change事件，在微调框控件的Value属性发生变动时，将变动量乘0.01后赋给文本框，使文本框的变动量每次为0.01。
 窗体运行后效果如图所示。

 

第8部分 控件与用户窗体
技巧121 不打印工作表中的控件 在打印工作表时，如果工作表中有控件，会把控件也一起打印出来，从而影响打印出来的工作表的美观。
经过简单的设置能使工作表中的控件不被打印出来。

121-1 设置控件格式

如果工作表中的是窗体控件，设置时右键单击控件，在显示的右键快捷菜单中选择“设置控件格式”，在“设置控件格式”选项卡中选择“属性”页面，使“打印对象”前的复选框为空白状态，如图所示。

       如果工作表中的控件是ActiveX控件，那么需要在设计模式下右键单击控件，在显示的右键快捷菜单中选择“设置控件格式”，在“设置控件格式”选项卡中选择“属性”页面，使“打印对象”前的复选框为空白状态，如图所示。

121-2 设置控件的printobjcet属性

如果工作表中的控件是ActiveX控件，使用除了使用技巧121-1的方法外，还可以在设计模式下右键单击控件，选择“属性”，设置控件的printobjcet属性为False。
如图所示。

第8部分 控件与用户窗体
技巧122 在框架中使用滚动条 如果需要在窗体中显示较多的内容，比如使用标签显示一段很长的文本内容，而又不希望窗体很大的话，可以在窗体中使用框架放置标签，设置框架可滚动区域的高度，使标签可以进行上下移动以查看全部区域。
        在VBE窗口中单击菜单“插入”→“用户窗体”，在窗体中添加一个框架控件，在框架中添加一个标签控件。
根据需要显示的内容调整好标签的大小，再将框架和窗体调整为合适的大小。
        在VBE中双击窗体，写入下面的代码。

  Private Sub UserForm_Initialize()
      Dim sLab As String
      sLab = Space(4) & "欢迎来到ExcelHome技术论坛，全球最领先的Excel技术论坛之一。
" & vbLf _
          & Space(4) & "在这里，我们讨论Microsoft Office系列产品的应用技术，重点讨论Microsoft Excel。
本论坛从属于Excel Home这一全球最大的华语Excel技术门户，目前是个人、非营利性质的网站学习平台。
各行各业的Excel使用者都活跃在此，各种形式的学习资源也汇聚于在此，所以，只要您愿意花时间，并使用正确的方法，我们有理由相信您的绝大部分应用问题和学习愿望都在这里被满足。
无数已经取得了非凡进步的人，也可以证明这一点。
" & vbLf _
          & Space(4) & "Let’s do it better!这是Excel Home的口号，我们的宗旨是帮助大家解决在使用Office软件中的问题，提升自己的应用技能。
" & vbLf _
          & Space(4) & "鉴于许多人在此之前没有正确使用网络学习资源的经验，或者对Excel Home的行为规则缺乏了解，我们特别准备了这样一篇文章，送给每一位有志与我们一起成长的朋友。
本文将重点叙述学习方法和论坛的规则，对于如何使用论坛的各项功能，请阅读论坛的帮助系统（http://club.excelhome.net/boardhelp.asp ）"
      Label1.Caption = sLab
      With Frame1
          .ScrollBars = 2
          .ScrollHeight = Label1.Height
      End With
  End Sub
       窗体的初始化事件，在窗体加载时使用标签显示文本内容。
        第3行到第6行代码，变量sLab为要显示的文本，使用Space函数在每段的首字前插入4个空格，使首字缩进。
在需要换行的地方插入常数vbLf进行换行。
        第9行代码，设置框架的ScrollBars属性为显示垂直滚动条。
ScrollBars属性指定一个控件、窗体或页面是否有垂直或水平滚动条，或两者都有，语法如下：
object.ScrollBars [= fmScrollBars] 参数object是必需的，一个有效的对象。
        参数fmScrollBars是可选的，滚动条的显示位置，设置值如所示。

       第10行代码，设置框架的ScrollHeight属性为标签的高度。
ScrollHeight属性指定通过移动控件、窗体或页面中的滚动条，可以查看的全部区域的高度，语法如下：
object.ScrollHeight [= Single] 参数object是必需的，一个有效的对象。
        参数Single是可选的，可滚动区域的高度。
        如果框架具有水平滚动条，可以设置框架的ScrollWidth属性来设置可以查看的全部区域的宽度。
        运行窗体，使用标签显示文本内容，可通过框架的滚动条查看全部内容，如图所示。

第8部分 控件与用户窗体
技巧123 使用多页控件 在处理可以划分为不同类别的大量信息时可以使用多页控件。
例如，在示例中，多页控件的第一页用于显示欢迎信息，另三页显示其他信息。
利用多页控件能够将相关信息组织在一起显示出来，同时又能够随时访问整条记录。
        多页控件中的每个页面都是一个窗体，含有自己的控件，并且可以有唯一的布局。
一般情况下，多页控件中的页面都有标签，以便让用户选择单个页面。
        在窗体中使用多页控件时，往往希望窗体显示时能显示特定的页面，比如每次打开窗体时先显示第一页的欢迎信息，除了在VBE中选择多页控件的第一页后保存外，还可以通过设置多页控件的Value属性来实现，如下面的代码所示。

  Private Sub UserForm_Initialize()
      MultiPage1.Value = 0
  End Sub
       窗体的Initialize事件，在窗体显示时选择多页控件的第一页。
       控件的Value属性定义某给定的控件的状态或内容，对于多页控件标识当前激活页。
Value属性是多页控件的默认属性，该属性返回当前活动页面的索引编号（位于多页控件的Pages集合中），零 ( 0 ) 表示是第一页，最大值比总页数少一。
        多页控件的默认事件是Change事件，示例中使用消息框显示当前活动页面的Caption属性，代码如下：
  Private Sub MultiPage1_Change()
      If MultiPage1.SelectedItem.Index > 0 Then
          MsgBox "欢迎来到" & MultiPage1.SelectedItem.Caption & "版块!"
      End If
  End Sub
       MultiPage1_Change过程根据当前活动页面是否是第一页，如果不是则使用消息框显示当前活动页面的Caption属性。
        应用于Page对象的Index属性指Pages集合中Page对象的位置，语法如下：
object.Index [= Integer] 参数object是必需的，一个有效对象。
        参数Integer是可选的，当前选定的Page对象的索引。
        Index 属性指定了标签出现的顺序，改变Index属性的值将改变多页控件中页面的顺序，第一页的索引值是0，第二页的索引值是 1，依此类推。
        应用于多页控件的SelectedItem属性返回当前选中的Page对象，SelectedItem属性是只读的，用SelectedItem属性可对当前选中的Page对象进行可编程控制。
        运行窗体，多页控件显示第一页的欢迎信息，当选择其他页面时显示提示信息，如图所示。

第8部分 控件与用户窗体
技巧124 标签文字垂直居中对齐 在使用标签控件为其他控件作题注时，只能设置题注文字在水平方向的对齐方式，不能设置为垂直居中。
要达到题注文字垂直居中的效果，可以使用两个标签控件组合来完成。
        步骤1，在窗体中添加一个标签控件Label1，将Caption属性设置为空，再设置需要的背景颜色及边框颜色。
        步骤2，添加一个标签控件Label2，将Caption属性设置为需要的标题；AutoSize属性设置为True，BackStyle属性设置为0，TextAligh属性设置为fmTextAlignCenter，其它属性不改变。
        AutoSize属性规定对象是否自动调整大小以显示其完整的内容，语法如下：
object.AutoSize [= Boolean] 参数object是必需的，一个有效对象。
        参数Boolean是可选的，是否自动调整大小。
设置为True控件可自动调整大小以显示其完整的内容，设置为False控件尺寸保持不变。
如果内容超出了控件的区域，内容将被剪裁（默认）。
        BorderStyle属性指定控件或窗体的边框类型，语法如下：
object.BorderStyle [= fmBorderStyle] 参数object是必需的，一个有效对象。
        参数fmBorderStyle是可选的，指定边框类型，设置值如表格所示。

       TextAligh属性定义控件中文本的对齐方式，语法如下：
object.TextAlign [= fmTextAlign] 参数object是必需的，一个有效对象。
        参数fmTextAlign是可选的，控件中文本的对齐方式，设置值如表格所示。

       步骤3，同时选中两个标签控件，在右键弹出菜单中选择“统一尺寸”→“宽度相同”，再右击选择“对齐”→“左对齐”，重新右键“对齐”→“中间对齐”。
        步骤4，最后同时选中两个标签控件，在右键弹出菜单中选择“生成组”，就达到标题为垂直居中的效果了，如图中左边的标签所示。

点评
jsxjd
重置 label2.Caption 起不到效果的
声明变量类型时，声明为INTEGER、LONG、STRING等类型，有何技巧？即何时声明为INTEGER、LONG、STRING等类型呢？有何区别？
根据你所需的数据类型进行声明，如字符型的设置为String数据类型，范围为 -32,768 到 32,767 之间的整数型声明为Integer，超出32,767 的声明为Long 数据类型等等。
具体请参阅VBA的数据类型帮助。

各位大师：你们好！ 764楼的问题是：其代码运行到rng = [a65536].End(xlUp).Row时，就会出错！
数据类型声明错误？附件的A列最后一行超过32,767 行？
EXCEL中图片上的右键菜单在哪里可以找到（通过代码）？上述“禁用工作表右键菜单”的代码好像不能禁止此类菜单！（我用的是2007）。
烦请版主赐教哟！
上述代码在2003中可以同时禁用工作表、图表、图片中的右键菜单，2007版本的我没用过。

请问yuanzhuping 楼主，我的这个窗体怎么修改呢，请你帮忙
http://club.excelhome.net/thread-422238-1-1.html
请参考下此贴的内容。

http://club.excelhome.net/viewth ... p;page=1#pid2539060
注：n列数据行不确定，现需从两个窗体的组合框中分别选定的将值赋予添加a数据、添加b数据。
请问vba语句怎么写？
不是太明白您的意思，请参考技巧109 组合框和列表框添加列表项的方法
http://club.excelhome.net/viewth ... ;page=64#pid2670654
https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=23
本帖已被收录到知识树中，索引项：开发帮助和教程
如何用工作表事件编程，使选中一个单元格后，该单元格的值自动加一
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Target = Target + 1 End Sub
可以用循环语句实现选中多个工作表吗？
http://club.excelhome.net/viewth ... ;page=11#pid2535231
第8部分 控件与用户窗体
技巧125 使用TabStrip控件 使用TabStrip控件，可以在用户窗体中的同一区域定义多个数据页面，也就是说使用TabStrip控件可以使用户窗体中的同一组控件根据TabStrip控件所选择的页面具有不同的功能，而不必像多页控件那样需要在每个页面中放置相同的控件。
        在示例的窗体中使用一个图像控件和一个标签控件，根据TabStrip控件所选择的页面来显示相应城市的图片和标签控件的题注。
        步骤1，在窗体中添加一个TabStrip控件，默认情况下，一个TabStrip控件包含两个页面，所以需要在TabStrip控件上右键单击，在显示的右键菜单中选择“新建页”继续添加三个页面。
因为TabStrip控件不像多页控件具有分页的属性窗口，所以需要在显示的右键菜单中选择“重命名”将页面分别重命名为各城市的名称。
        步骤2，在TabStrip控件上添加一个Image控件和一个Label控件，调整为合适的大小。
        步骤3，双击窗体写入下面的代码：
  Private Sub TabStrip1_Change()
      Dim FilPath As String
      FilPath = ThisWorkbook.Path & "" & TabStrip1.SelectedItem.Caption & ".jpg"
      Image1.Picture = LoadPicture(FilPath)
      Label1.Caption = TabStrip1.SelectedItem.Caption & "欢迎您!"
  End Sub
  Private Sub UserForm_Initialize()
      TabStrip1.Value = 0
  End Sub
       第1行到第6行代码，TabStrip控件的Change事件过程，根据TabStrip控件所选择的页面来显示相应城市的图片和标签控件的题注。
        第3行代码设置Image控件需加载图片的完整路径，使用SelectedItem属性返回TabStrip控件当前选中页面的Caption属性，即窗体中所选城市的名称，将图片的完整路径设置为保存在同一目录中已命名为所选城市的图片。
        第4行代码为Image控件加载图片。
Picture 属性指定显示在对象上的位图，语法如下：
object.Picture = LoadPicture( pathname ) 参数expression是必需的，一个有效的对象。
        参数pathname是必需的，一个图片文件的完整路径。
        第5行代码设置标签控件的题注为窗体中所选城市的名称和“欢迎您!”。
        第7行到第9行代码窗体的Initialize事件过程，为了使窗体显示时TabStrip控件显示第一页，将其Value设置为零 ( 0 )。
        运行窗体，选择不同的标签将显示不同城市的图片，如图所示。

       如果将TabStrip控件的Style属性设置为1则在标签条中显示的是按钮而不是标签，如图所示。

 

技巧4 定位单元格 在Excel中使用定位对话框可以选中工作表中特定的单元格区域，而在VBA中则使用SpecialCells方法，如下面的代码所示。
 复制内容到剪贴板代码:
  Sub SpecialAddress() ...
http://club.excelhome.net/viewth ... ;page=44#pid2614723
第8部分 控件与用户窗体
技巧126 显示GIF动画图片 如果希望在Excel中显示GIF格式的动画图片，可以使用AniGif控件。
        步骤1，在工作表中单击菜单“视图”→“工具栏”→“控件工具箱”→“其他控件”，选择“VBAniGIF. AniGif”后在工作表中拖动添加AniGif控件，如图所示。

       如果“其他控件”中没有该控件，那么需要对该控件进行注册。
注册控件请参阅技巧118 。
AniGif控件的文件名为VBAniGIF.OCX，也可以在工作表中单击菜单“视图”→“工具栏”→“控件工具箱”→“其他控件”，选择“注册自定义控件”，在显示的对话框中选择VBAniGIF.OCX文件进行注册，如图所示。

       步骤2，在设计模式下右键单击AniGif控件，选择“属性”，设置AniGif控件的Filename属性为CIF图片所在的路径，如图所示。

       可以使用代码设置AniGif控件的Filename属性，如下面的代码所示。

  Private Sub Workbook_Open()
      Sheet1.AniGif1.Filename = ThisWorkbook.Path & "\001.gif"
  End Sub
       工作簿打开时将AniGif控件的Filename属性设置为同一目录中的“001.gif”文件。
        工作簿打开时可能出现如图所示的对话框，这是因为当打开包含ActiveX控件的文件时，如果该控件被标识为初始化不安全时，Office程序不加载或激活未被标志为初始化安全的ActiveX控件。

       解决此问题的方法是更改Office程序处理ActiveX组件的方式，需要对注册表进行修改。
也可以使用以下代码修改注册表：
  Sub RegWriteProc()
      Dim WshShell
      Set WshShell = CreateObject("Wscript.Shell")
      WshShell.RegWrite "HKCU\Software\Microsoft\Office\Common\Security\UFIControls", 1, "REG_DWORD"
      WshShell.RegWrite "HKCU\Software\Microsoft\VBA\Security\LoadControlsInForms", 1, "REG_DWORD"
      Set WshShell = Nothing
  End Sub
       RegWriteProc过程修改注册表设置。
第4行代码将UFIControls子项设置为1（最不安全）。
第5行代码将LoadControlsInForms子项设置为1（最不安全）。
关于为ActiveX控件授予权限请参阅微软的技术文章：http://support.microsoft.com/kb/827742/zh-cn 退出设计模式后，将在工作表中显示GIF动画图片，如图所示。

 

1

征婚启事
第8部分 控件与用户窗体
技巧127 播放Flash文件 如果需要在工作表中播放Flash文件，那么可以使用ShockwaveFlash控件。
        步骤1，在工作表中单击菜单“视图”→“工具栏”→“控件工具箱”→“其他控件”，选择“ShocKwave Flash Object”后在工作表中拖动添加ShockwaveFlash控件，如图所示。

       如果“其他控件”中没有该控件，请参阅技巧126 对其进行注册，ShockwaveFlash控件的文件名为Flash9d.OCX。
        步骤2，在设计模式下右键单击ShockwaveFlash控件，选择“属性”，设置ShockwaveFlash控件的Base属性和Movie属性为Flash文件所在的路径，设置Embedmovie属性为True，使Flash文件嵌入到Excel中，如图所示。

       可以使用代码设置ShockwaveFlash控件的各项属性，如下面的代码所示。

  Private Sub Workbook_Open()
      With Sheet1.ShockwaveFlash1
          .Base = ThisWorkbook.Path & "\face.swf"
          .Movie = ThisWorkbook.Path & "\face.swf"
          .EmbedMovie = True
      End With
  End Sub
       工作簿打开时将ShockwaveFlash控件的Base属性和Movie属性设置为同一目录中的“face.swf”文件，设置Embedmovie属性为True。
        退出设计模式后，将在工作表中显示Flash动画，如图所示。

第8部分 控件与用户窗体
技巧128 在工作表中添加窗体控件 在工作表中添加窗体控件，除了使用手工添加外，还可以使用代码添加，方法如下：

128-1 使用AddFormControl方法

使用AddFormControl方法在工作表中添加窗体控件，如下面的代码所示。

  Sub AddFormControls()
      Dim myShape As Shape
      On Error Resume Next
      Sheet1.Shapes("myButton").Delete
      Set myShape = Sheet1.Shapes.AddFormControl(0, 108, 72, 108, 27)
      With myShape
          .Name = "myButton"
          With .TextFrame.Characters
              .Font.ColorIndex = 3
              .Font.Size = 12
              .Text = "新建的按钮"
          End With
          .OnAction = "myButton"
      End With
  End Sub
  Sub myButton()
      MsgBox "这是使用AddFormControl方法新建的按钮!"
  End Sub
       AddFormControls过程使用AddFormControl方法在工作表中添加窗体控件。
        第3、4行代码为了避免在工作表中重复添加按钮控件，先删除工作表中的“myButton”按钮。
       第5行代码，使用AddFormControl方法在工作表中添加命令按钮控件并设置控件的坐标和大小。
应用于Shapes对象的AddFormContl方法创建一个Microsoft Excel控件，返回一个Shape对象，该对象代表新建的控件，语法如下：
expression.AddFormControl(Type, Left, Top, Width, Height) 参数expression是必需的，一个有效的对象。
        参数Type是必需的，Microsoft Excel控件类型，可以为表格所列XlFormControl 常量之一。

       参数Left是必需的，新对象的初始坐标（以磅为单位）相对于工作表 A1 单元格的左上角或图表的左上角。
        参数Top是必需的，新对象的初始坐标（以磅为单位）相对于工作表 A1 单元格的左上角或图表的左上角。
        参数Width是必需的，以磅为单位的新对象的初始大小。
        参数Height是必需的，以磅为单位的新对象的初始大小。
        第7行代码将新添加的按钮名称设置为“myButton”。
        第8行到第12行代码设置新添加的按钮文字设置为“新建的按钮”，并设置文字的大小和颜色。
        第13行代码，指定新添加按钮所执行的宏名称。
        myButton过程是单击新添加按钮所执行的过程，显示一个消息框。
        运行AddFormControls过程将在工作表中添加一个命令按钮，单击按钮显示一个消息框，如图所示。

128-2 使用Add方法

在工作表中添加窗体控件还可以使用Add方法，如下面的代码所示。

  Sub AddChartObjects()
      Dim myButton As Button
      On Error Resume Next
      Sheet1.Shapes("myButton").Delete
      Set myButton = Sheet1.Buttons.Add(108, 72, 108, 27)
      With myButton
          .Name = "myButton"
          .Font.Size = 12
          .Font.ColorIndex = 5
          .Characters.Text = "新建的按钮"
          .OnAction = "myButton"
      End With
  End Sub
  Sub myButton()
      MsgBox "这是使用Add方法新建的按钮!"
  End Sub
       AddChartObjects过程使用Add方法在工作表中添加窗体控件。
        第3、4行代码为了避免在工作表中重复添加按钮控件，先删除工作表中的“myButton”按钮。
        第5行代码，使用Add方法在工作表中添加命令按钮控件，Add方法适用于ChartObjects对象的语法如下：
expression.Add(Left, Top, Width, Height) 参数expression是必需的，该表达式返回一个ChartObjects对象。
        如果需要在工作表中添加其他窗体控件，可以将参数expression设置为表格所示的ChartObjects对象之一。

       参数Left和Top是必需的，以磅为单位给出新对象的初始坐标，该坐标是相对于工作表上单元格 A1 的左上角或图表的左上角的坐标。
        参数Width和参数Height是必需的，以磅为单位给出新对象的初始大小。
        第7行代码将新添加的按钮的名称设置为“myButton”。
        第8行到第10代码新添加的按钮的文字设置为“新建的按钮”并设置文字的大小和颜色。
        第11行代码，指定新添加命令按钮所执行的宏名称。
        myButton过程是单击新添加按钮所执行的过程，显示一个消息框。
        运行AddChartObjects过程将在工作表中添加一个命令按钮，单击按钮显示一个消息框，如图所示。

请哪位朋友帮个忙，上传个Spreadsheet控件的文件给我，我电脑重装系统后，Spreadsheet控件不好用了。
谢谢昂。

Spreadsheet 控件是OWC的一部分，在Office03安装选项中选择安装“Office Web Component"，或者到微软网站下载，下载后运行owc11.exe，安装之后就可以看到该控件了。

http://www.microsoft.com/downloads/deta ...
多谢郗兄，已经解决了。

第8部分 控件与用户窗体
技巧129 在工作表中添加ActiveX控件 技巧128 中使用代码在工作表中添加的是窗体控件，而本例中使用代码在工作表中添加的是ActiveX控件，两者是有区别的，在工作表中前者是使用窗体对话框添加，而后者是使用控件工具箱添加，如图所示。

129-1 使用Add方法

使用Add方法在工作表中添加ActiveX控件，如下面的代码所示。

  Sub AddObj()
      Dim Obj As New OLEObject
      On Error Resume Next
      Sheet1.OLEObjects("MyButton").Delete
      Set Obj = Sheet1.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
              Left:=108, Top:=72, Width:=108, Height:=27)
      With Obj
          .Name = "MyButton"
          .Object.Caption = "新建的按钮"
          .Object.Font.Size = 16
          .Object.ForeColor = &HFF&
      End With
      With ActiveWorkbook.VBProject.VBComponents(Sheet1.CodeName).CodeModule
          If .Lines(1, 1) <> "Option Explicit" Then
              .InsertLines 1, "Option Explicit"
          End If
          If .Lines(2, 1) = "Private Sub MyButton_Click()" Then Exit Sub
          .InsertLines 2, "Private Sub MyButton_Click()"
          .InsertLines 3, vbTab & "MsgBox ""这是使用Add方法新建的按钮!"""
          .InsertLines 4, "End Sub"
      End With
  End Sub
       AddOLEObject过程使用Add方法在向工作表中添加ActiveX控件中的命令按钮和相应的代码。
        第3、4行代码为了避免在工作表中重复添加按钮控件，先删除工作表中的名称为“myButton”的按钮。
        第5、6行代码，使用Add方法在向工作表中添加ActiveX控件中的命令按钮，Add方法应用于OLEObjects 对象的语法如下：
expression.Add(ClassType, FileName, Link, DisplayAsIcon, IconFileName, IconIndex, IconLabel, Left, Top, Width, Height) 其中参数expression是必需的，返回一个 OLEObjects 对象。
        参数ClassType是可选的，创建的对象的程序标识符。
如果指定了 ClassType参数，则忽略FileName参数和Link参数。
        在本例中指定添加控件的程序标识符为“Forms.CommandButton.1”，即命令按钮控件，关于对象的程序标识符请参阅技巧119-3。
        参数Left和参数Top是必需的，以磅为单位给出新对象的初始坐标，该坐标是相对于工作表上单元格 A1 的左上角或图表的左上角的坐标。
        参数Width和参数Height是可选的，以磅为单位给出OLE对象的初始大小。
        第8行代码，设置命令按钮的名称为“MyButton”。
        第9行代码，设置命令按钮的文字为“新建的按钮” 第10行代码，设置命令按钮的文字的大小。
        第11行代码，设置命令按钮的文字的颜色。
        第13行到第21行代码，在工作表中写入新添加的命令按钮的单击事件代码。
        ActiveX控件不能像窗体控件用OnAction属性来指定宏，需要使用CodeModule对象的InsertLines方法在工作表中插入代码。
        应用于CodeModule对象的InsertLines方法的语法如下：
object.InsertLines(line, code) 参数object是必需的，一个有效的对象。
        参数line是必需的，用来指定要插入代码的位置。
        参数code是必需的，要插入的代码。
        第14行到第16行代码判断首行内容是否为要求变量声明，如不是则添加要求变量声明语句。
        第17行到第20行代码判断是否已存在相同名称的过程，如不存在则使用InsertLines方法在工作表中插入代码。
        运行AddOLEObject过程，将在工作表中添加一个命令按钮和相应的代码，单击按钮显示一个消息框，如图所示。

129-2 使用AddOLEObject方法

在工作表中添加ActiveX控件，还可以使用AddOLEObject方法，如下面的代码所示。

  Sub AddShapes()
      Dim ShpBut As Shape
      On Error Resume Next
      Sheet1.OLEObjects("MyButton").Delete
      Set ShpBut = Sheet1.Shapes.AddOLEObject(ClassType:="Forms.CommandButton.1", _
              Left:=108, Top:=72, Width:=108, Height:=27)
              ShpBut.Name = "MyButton"
      With ActiveWorkbook.VBProject.VBComponents(Sheet1.CodeName).CodeModule
          If .Lines(1, 1) <> "Option Explicit" Then
              .InsertLines 1, "Option Explicit"
          End If
          If .Lines(2, 1) = "Private Sub MyButton_Click()" Then Exit Sub
          .InsertLines 2, "Private Sub MyButton_Click()"
          .InsertLines 3, vbTab & "MsgBox ""这是使用AddOLEObject方法新建的按钮!"""
          .InsertLines 4, "End Sub"
      End With
  End Sub
       AddShapes过程使用AddOLEObject方法在向工作表中添加ActiveX控件中的命令按钮和相应的代码。
        第5、6行代码，使用AddOLEObject方法在向工作表中添加ActiveX控件中的命令按钮，AddOLEObject方法创建OLE对象，语法如下：
expression.AddOLEObject(ClassType, FileName, Link, DisplayAsIcon, IconFileName, IconIndex, IconLabel, Left, Top, Width, Height) AddOLEObject方法参数与Add方法类似，请参阅技巧129-1。
        运行AddShapes过程，将在工作表中添加一个命令按钮和相应的代码，单击按钮显示一个消息框，如图所示。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=24
第8部分 控件与用户窗体
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧130 使用spreadsheet控件 如果希望在窗体中显示类似工作表的表格，并且可以像工作表一样进行操作，那么可以在窗体中使用表格控件（Spreadsheet控件）。
        步骤1，在VBE窗口中单击菜单“插入”→“用户窗体”，在窗体上添加一个Spreadsheet控件，双击窗体，在其代码窗口中输入下面的代码：
  Private Sub UserForm_Initialize()
      Dim iRow As Integer
      Dim arr As Variant
      With Me.Spreadsheet1
          .DisplayToolbar = False
          .DisplayHorizontalScrollBar = False
          .DisplayVerticalScrollBar = False
          .DisplayWorkbookTabs = False
          iRow = Sheet1.Range("B65536").End(xlUp).Row
          arr = Sheet1.Range("B2:H" & iRow)
          With .Range("B2:H" & iRow)
              .Value = arr
              .Borders.LineStyle = xlContinuous
              .Borders.Weight = xlMedium
              .Borders.ColorIndex = 10
          End With
          With .Range("B2:H2")
              .HorizontalAlignment = -4108
              .VerticalAlignment = -4108
              .Interior.ColorIndex = 44
          End With
          .Range("B3:B" & iRow).HorizontalAlignment = -4108
          .Range("C3:H" & iRow).NumberFormat = "0.00"
          .Rows(2).RowHeight = 23.25
          .Columns("A").ColumnWidth = 2.75
          .Columns("B:H").ColumnWidth = 8
      End With
  End Sub
       用户窗体的初始化事件过程，使用窗体显示工作表中的表格。
        第5行代码，设置Spreadsheet控件不显示工具栏。
        DisplayToolbar 属性设置工具栏是否隐藏，语法如下：
expression.DisplayToolbar 参数expression是必需的，一个有效的对象。
       如果指定电子表格、图表区或“数据透视表”列表显示了工具栏，则返回True。
        第6、7行代码，设置Spreadsheet控件不显示水平和垂直滚动条。
        第8行代码，设置Spreadsheet控件不显示工作表标签。
        第9行代码，取得工作表B列有数据的最后一行的行号。
        第10行代码，把工作表数据赋值给数组。
        第11行到16行代码，把数组赋给Spreadsheet控件的单元格，使Spreadsheet控件显示工作表内容，并且添加加框线。
        第17行到第21行代码，设置Spreadsheet控件中表格第一行的字体对齐方式为居中并添加单元格的底纹颜色。
        第22行代码，设置Spreadsheet控件中表格第一列的字体对齐方式为居中。
        第23行代码，设置Spreadsheet控件中表格数据的格式。
        第24行到26行代码，设置Spreadsheet控件的行高与列宽。
        步骤2，在窗体上添加一个按钮控件，将其Caption属性设置为“保存”，双击按钮控件，在其代码窗口中输入下面的代码：
  Private Sub CommandButton1_Click()
      Dim iRow As Integer
      Dim arr As Variant
      If MsgBox("是否保存对表格所作的修改?", 4 + 32) = 6 Then
          With Me.Spreadsheet1
              iRow = .Range("B65536").End(xlUp).Row
              arr = .Range("B2:H" & iRow).Value
              Sheet1.Range("B2:H" & iRow).Value = arr
          End With
      End If
      Unload Me
  End Sub
       用户窗体中“保存”按钮的单击过程，把在窗体中对数据的修改重新保存到工作表。
        第4行代码，询问用户是否保存修改。
        第5行到第10行代码，如果用户选择保存，把Spreadsheet控件中的数据保存到工作表。
        运行窗体，显示效果如图所示。

第8部分 控件与用户窗体
技巧131 使用Listview控件 ListView控件是VBA程序开发中的常用控件，可以在用户窗体中把工作表的数据以列表的方式显示。

131-1 使用Listview控件显示数据列表

使用Listview控件在用户窗体中显示数据列表，代码如下：
  Private Sub UserForm_Initialize()
      Dim Itm As ListItem
      Dim r As Integer
      Dim c As Integer
      With ListView1
          .ColumnHeaders.Add , , "人员编号 ", 50, 0
          .ColumnHeaders.Add , , "技能工资 ", 50, 1
          .ColumnHeaders.Add , , "岗位工资 ", 50, 1
          .ColumnHeaders.Add , , "工龄工资 ", 50, 1
          .ColumnHeaders.Add , , "浮动工资 ", 50, 1
          .ColumnHeaders.Add , , "其他 ", 50, 1
          .ColumnHeaders.Add , , "应发合计", 50, 1
          .View = lvwReport
          .Gridlines = True
          For r = 2 To Sheet1.[A65536].End(xlUp).Row
              Set Itm = .ListItems.Add()
              Itm.Text = Space(2) & Sheet1.Cells(r, 1)
              For c = 1 To 6
                  Itm.SubItems(c) = Format(Sheet1.Cells(r, c + 1), "##,#,0.00")
              Next
          Next
          End With
      Set Itm = Nothing
  End Sub
       窗体的初始化事件，在窗体显示时将工作表中数据显示在Listview控件中。
        第6行到第12行代码，使用ColumnHeader对象的Add方法在Listview控件中添加标题列，并设置列标题、列宽和文本对齐方式。
        ColumnHeader对象是ListView控件中包含标题文字的项目，应用于ColumnHeader对象的Add方法语法如下：
object.ColumnHeader.Add(index,key,text,width,alignment) 其中参数text代表标题文字，参数width代表标题的列宽，参数alignment代表列标题中文本对齐方式。
Listview控件中文本的对齐方法有三种，如表格所示。

       在Listview控件中第一列的文本对齐方式只能设置为左对齐。
        第13行代码，设置Listview控件的View属性为lvwReport，使Listview控件显示为报表型。
View属性决定在列表中控件使用何种视图显示项目，语法如下：
object.view [= value] 参数object是必需的，对象表达式，listview控件。
        参数value是必需的，指定控件外观的整数或常数，如表格所示。

第14行代码，设置Listview控件的Gridlines属性为True，显示网格线。
只有在将View属性设置为lvwReport时才能显示网格线，否则Gridlines属性无效。
 第16行代码，使用ListItem对象的Add方法在Listview控件中添加项目。
应用于ListItem对象的Add方法语法如下： ListItems.Add(index,key,text,icon,smallIcon) 其中参数text代表添加的项目内容。
        第17行代码，添加行标题。
ListItem对象的text属性代表Listview控件的第一列内容，因为Listview控件的第一列的文本对齐方式只能设置为左对齐，所以在添加时使用Space函数插入两个空格，使行标题达到居中显示的效果。
        第18行到20行代码，继续添加其他列的内容。
Listview控件其他列的项目需要使用SubItems属性来添加。
        运行窗体，Listview控件显示工作表中的内容，如图所示。

你好，我是Excel VBA的新手，看了“Excel VBA实战技巧精粹视频教程[Excel Home]D07_在VBA中使用类创建控件数组” 的讲解，我利用之类化做了一个现实工作中的例子，但运行后达不到效果，还请大侠帮忙查看， 不胜感激！ ...
在此我再和EH的朋友们说声抱歉，我在前面就说过，此贴不是问题贴，请有问题的朋友们另外发贴，相信解决的速度更快，在此向也前面的朋友道声抱歉，类，我也在学习中，有相关的问题请请教QEE版版，他是权威。
还有有问题请上传附件，在EH，没有解决不了的问题。

求教版主 技巧130中，添加Spreadsheet控件，如何操作,找不着控件啊。
 工具箱只有这些内容：
在工具箱右击，选择附加控件，然后选择Spreadsheet控件。

第8部分 控件与用户窗体
技巧131 使用Listview控件

131-2 在Listview控件中使用复选框

在Listview控件中使用复选框，可以进行多重选择，示例代码如下：
  Private Sub UserForm_Initialize()
      Dim Itm As ListItem
      Dim r As Integer
      Dim c As Integer
      With ListView1
          .ColumnHeaders.Add , , "人员编号 ", 50, 0
          .ColumnHeaders.Add , , "技能工资 ", 50, 1
          .ColumnHeaders.Add , , "岗位工资 ", 50, 1
          .ColumnHeaders.Add , , "工龄工资 ", 50, 1
          .ColumnHeaders.Add , , "浮动工资 ", 50, 1
          .ColumnHeaders.Add , , "其他 ", 50, 1
          .ColumnHeaders.Add , , "应发合计", 50, 1
          .View = lvwReport
          .Gridlines = True
          .FullRowSelect = True
          .CheckBoxes = True
          For r = 2 To Sheet2.[A65536].End(xlUp).Row - 1
              Set Itm = .ListItems.Add()
              Itm.Text = Sheet2.Cells(r, 1)
              For c = 1 To 6
                  Itm.SubItems(c) = Format(Sheet2.Cells(r, c + 1), "##,#,0.00")
              Next
          Next
          End With
      Set Itm = Nothing
  End Sub
  Private Sub CommandButton1_Click()
      Dim r As Integer
      Dim i As Integer
      Dim c As Integer
      r = Sheet1.[A65536].End(xlUp).Row
      If r > 1 Then Sheet1.Range("A2:G" & r) = ""
      With ListView1
          For i = 1 To .ListItems.Count
              If .ListItems(i).Checked = True Then
                  Sheet1.Range("A65536").End(xlUp).Offset(1, 0) = .ListItems(i)
                  For c = 1 To 6
                      Sheet1.Cells(65536, c + 1).End(xlUp).Offset(1, 0) = .ListItems(i).SubItems(c)
                  Next
              End If
          Next
      End With
  End Sub
      第1行到第26行代码，用户窗体的Initialize事件过程，在窗体显示时将工作表中数据显示在Listview控件中，请参阅技巧131-1。
        其中第15行代码设置Listview控件的FullRowSelect属性为True，使用户可以选择整行。
        第16行代码设置Listview控件的CheckBoxes属性为True，使Listview控件在列表的每个项的旁边显示复选框。
        第27行到第43行代码，用户窗体中“保存”按钮的单击过程，将Listview控件中选中的项目写入到工作表中。
        第31、32行代码，删除工作表中原有的数据， 第34、35行代码遍历Listview控件中所有的ListItem对象，判定其Checked值，如果为True，即说明其处于选中状态。
        第36行到第40行代码将Listview控件中选中的内容依次写入到工作表中。
        运行窗体，Listview控件显示工作表中的内容，单击“保存”按钮将如Listview控件中选中的内容依次写入到工作表中，如图所示。

第8部分 控件与用户窗体
技巧131 使用Listview控件

131-3 调整Listview控件的行距

在使用Listview控件显示数据列表时，行距是由Listview控件所设置的字体大小决定的，无法自定义行距，即使调整了字体大小，行距还是很近。
        如果需要自定义Listview控件的行距，可以在窗体中添加一个ImageList控件，在ImageList控件中导入一张大小合适的空白图片，然后指定Listview控件的SmallIcons属性为ImageList控件中的图片，代码如下：
  Private Sub UserForm_Initialize()
      Dim Itm As ListItem
      Dim r As Integer
      Dim c As Integer
      Dim Img As ListImage
      With ListView1
          .ColumnHeaders.Add , , "人员编号 ", 50, 0
          .ColumnHeaders.Add , , "技能工资 ", 50, 1
          .ColumnHeaders.Add , , "岗位工资 ", 50, 1
          .ColumnHeaders.Add , , "工龄工资 ", 50, 1
          .ColumnHeaders.Add , , "浮动工资 ", 50, 1
          .ColumnHeaders.Add , , "其他 ", 50, 1
          .ColumnHeaders.Add , , "应发合计", 50, 1
          .View = lvwReport
          .Gridlines = True
          .FullRowSelect = True
          Set Img = ImageList1.ListImages.Add(, , LoadPicture(ThisWorkbook.Path & "" & "1×25.bmp"))
          .SmallIcons = ImageList1
          For r = 2 To Sheet1.[A65536].End(xlUp).Row - 1
              Set Itm = .ListItems.Add()
              Itm.Text = Space(2) & Sheet1.Cells(r, 1)
              For c = 1 To 6
                  Itm.SubItems(c) = Format(Sheet1.Cells(r, c + 1), "##,#,0.00")
              Next
          Next
      End With
      Set Itm = Nothing
      Set Img = Nothing
  End Sub
       用户窗体的Initialize事件过程，在窗体显示时将工作表中数据显示在Listview控件中并调整Listview控件的行距。
        第17行代码使用Add方法在ImageList控件中添加图片。
ImageList控件是一个向其他控件提供图像的资料中心，它包含了一组ListImage对象即一组图像的集合，该集合中的每个对象都可以通过其索引或关键字被其他控件所引用，但控件本身并不能单独使用。
        在运行时给ImageList控件添加图片需要使用Add方法，语法如下：
Add(index,key,picture) 参数index是可选的，整数，指定要插入的ListImage对象的位置。
如果没有指定index，ListImage对象将被添加到ListImages集合的末尾。
        参数key是可选的，用来标识ListImage对象的唯一字符串。
        参数picture是必需的，指定欲添加到集合中的图片。
        也可以在设计时在ImageList控件中添加图片，这样就无需在文件夹中保留图片文件。
在VBE中选择ImageList控件属性页中的“自定义”，在显示的“属性页”对话框中插入图片，如图所示。

       第18行代码，指定Listview控件的SmallIcons属性为ImageList控件中的图片，使用图片来调整行距。
        运行窗体，Listview控件显示工作表中的内容，调整Listview控件的行距，如图所示。

 

第8部分 控件与用户窗体
技巧131 使用Listview控件

131-4 在Listview控件中排序

在使用Listview控件显示报表型的数据时，可能通过单击Listview控件的列标题对列表数据进行排序，代码如下：
  Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
      With ListView1
          .Sorted = True
          .SortOrder = (.SortOrder + 1) Mod 2
          .SortKey = ColumnHeader.Index - 1
      End With
  End Sub
       Listview控件的ColumnClick事件过程，单击列标题时触发，对列表数据进行升序或降序排序。
        第3行代码将Listview控件的Sorted属性设置为True。
Sorted属性返回或设置确定ListView控件中的ListItem对象是否排序，设置为False则不进行排序。
        第4行代码设置Listview控件的排序方式。
SortOrder属性返回或设置一个值，决定ListView控件中的ListItem对象以升序或降序排序，设置为0以升序排序，设置为1则以降序排序。
在设置SortOrder属性值时使用Mod运算符以达到第一次排序以降序排序，再次排序时以升序排序，交替进行的效果。
        第5行代码设置Listview控件排序关键字的整数，即指定Listview控件以当前选定的列数据进排序。
SortKey属性返回或设置一个值，此值决定ListView控件中的ListItem对象如何排序，语法如下：
object.SortKey [=integer] 参数object是必需的，对象表达式，其值为ListView控件。
        参数integer是必需的，指定排序关键字的整数，设置为0使用ListItem对象的Text属性排序，即第一列的数据进行排序。
设置为大于0的整数则使用子项目的集合索引排序。
        运行窗体，Listview控件显示工作表中的内容，单击列标题对列表数据进行升序或降序排序，如图所示。

第8部分 控件与用户窗体
技巧131 使用Listview控件

131-5 Listview控件的图标设置

ListView 控件作为一个可以显示图标或者子项的列表控件，可以在控件中显示自定义的图标，它最重要的属性就是View 属性，该属性决定了以哪种视图模式显示控件的项，请参阅技巧131-1。
        在ListView 控件中显示图标，需要在用户窗体中添加一个ImageList控件用于保存图像文件。
关于ImageList控件的使用请参阅技巧131-3。
        以大图标模式显示ListView控件的代码如下：
  Private Sub UserForm_Initialize()
      Dim ITM As ListItem
      Dim r As Integer
      With ListView1
          .View = lvwIcon
          .Icons = ImageList1
          For r = 2 To 6
              Set ITM = .ListItems.Add()
              ITM.Text = Cells(r, 1)
              ITM.Icon = r - 1
          Next
      End With
      Set ITM = Nothing
  End Sub
       在用户窗体中以大图标模式显示ListView控件，可使用鼠标拖放图标，并重新排列。
        第5行代码将ListView控件的View属性设置为lvwIcon，大图标视图模式。
        第6行代码使用ListView控件的Icons 属性建立与ImageList控件的关联。
        第7行到第11行代码在ListView控件中添加ListItem对象，其中第10行代码设置使用ListItem对象的Icon属性指定其图像文件在ImageList控件中的编号。
        ListView控件以大图标视图模式显示时如图所示。

       以小图标模式显示ListView控件的代码如下：
  Private Sub UserForm_Initialize()
      Dim ITM As ListItem
      Dim r As Integer
      With ListView1
          .View = lvwSmallIcon
          .SmallIcons = ImageList1
          For r = 2 To 6
              Set ITM = .ListItems.Add()
              ITM.Text = Sheet1.Cells(r, 1)
              ITM.SmallIcon = r - 1
          Next
      End With
      Set ITM = Nothing
  End Sub
       在用户窗体中以小图标模式显示ListView控件，可使用鼠标拖放图标，并重新排列。
        第5行代码将ListView控件的View属性设置为lvwSmallIcon，小图标视图模式。
        与大图标视图模式有所不同的是，当使用小图标视图模式时需要使用ListView控件的SmallIcons属性建立与ImageList控件的关联，使用ListItem对象的SmallIcon属性指定其图像文件在ImageList控件中的编号。
        ListView控件以小图标视图模式显示时如图所示。

       将ListView控件的View属性设置为lvwList，以列表视图模式显示，如图所示。

       将ListView控件的View属性设置为lvwReport，以报表视图模式显示，如图所示。

1、Listview控件是否可以有标题行一样效果的固定的行号？ SpreadSheet控件是有的,但SpreadSheet控件不是office自带控件,加装可能涉及版权问题,而且用在自己开发的程序上,有不少功能是多余的。
      2、Listview控件是否有类似ListBox1列表控件的RowSource和数据源捆邦的属性，免得一条一条的插？ 3、 版主的例窗体上的ImageList1控件是不是一定要的，起什么作用？ 谢谢指教！！！
1、Listview控件没有标题行的效果。
 2、Listview控件只能使用Add方法插入ListItem对象。
 3、ImageList1控件是用于保存图像文件的。

第8部分 控件与用户窗体
技巧132 调用非模式窗体 在VBA中显示用户窗体需要使用Show方法，Show方法显示窗体对象，语法如下：
[object.]Show modal 参数object是可选的，对象表达式。
如果省略掉object，则将与活动的窗体模块相关联的窗体当作object。
        参数modal是可选的，决定窗体是模态的还是非模式的。
Modal参数的设置值如表格所示。
            当窗体显示时是模态时，用户在使用应用程序的其它部分之前，必须先对其作出响应。
在隐藏或卸载窗体之前，后续代码不会被执行。
        比如下面的代码，希望在显示窗体的同时给单元格赋值，但因为窗体显示为模态的，在窗体没有关闭之前，给单元格赋值的代码是不会执行的，所以达不到显示窗体的同时给单元格赋值的目的。

  Private Sub CommandButton1_Click()
      Dim i As Integer
      Columns(1).ClearContents
      UserForm1.Show 0
      For i = 1 To 1000
          Cells(i, 1) = i
      Next
  End Sub

UserForm1.Show 0
https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=25
第8部分 控件与用户窗体
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧133 进度条的制作 如果程序执行时间较长，使用进度条能让用户知道程序执行到何种程度，大约需等待多长时间，可以使界面显得友好。

133-1 使用进度条控件

使用窗体加进度条控件（ProgressBar）制作进度条是最常用的方法。
        在VBE窗口中单击菜单“插入”→“用户窗体”，在窗体上添加一个进度条控件，调整为合适的大小，如图所示。
           在工作表中添加一个命令按钮，双击后写入下面的代码。

  Private Sub CommandButton1_Click()
      Dim i As Integer
      UserForm1.Show 0
      With UserForm1.ProgressBar1
          .Min = 1
          .Max = 10000
          .Scrolling = 0
          For i = 1 To 10000
              Cells(i, 1) = i
              .Value = i
              UserForm1.Caption = "正在运行,已完成" & i / 100 & "%,请稍候!"
          Next
      End With
      Unload UserForm1
      Columns(1).ClearContents
  End Sub
       工作表中命令按钮的单击事件，在给工作表A1到A10000单元格赋值的同时使用进度条显示其运行速度。
        第3行代码，使用Show方法显示进度条控件所在的窗体，并且设置为无模式显示，请参阅技巧132 。
        第5、6行代码，设置进度条控件的最小值和最大值，应与第8行代码中的循环计数器的start参数和End参数相一致。
        第7行代码，设置进度条控件显示为有间隔的。
如果将Scrolling属性设置为1则显示为无间隔的。
        第9行代码，在单元格中进行无意义的填充数据以演示进度条。
在实际应用中可以将进度条嵌入到程序的循环中。
        第11行代码，在窗体的标题栏中显示已完成的百分比。
        第14行代码，使用Unload 语句卸载窗体。
        Unload 语句从内存中删除一个对象，语法如下： Unload object 参数object参数是必需的，一个有效的对象。
        第19行代码，清空A列填充的数据。
        单击工作表中的命令按钮，填充单元格并显示进度条，如图所示。
       
第8部分 控件与用户窗体
技巧133 进度条的制作

133-2 使用标签控件

在窗体中使用标签可以制作双色的进度条。
        步骤1，在VBE窗口中单击菜单“插入”→“用户窗体”，在窗体上添加一个框架控件，在框架控件中添加两个标签控件。
        步骤2，在控件的属性窗口中将框架的BackColor 属性设为&H000000FF&，使框架的背景色为红色。
将标签1的BackColor属性设为&H0000C000&，使标签1的背景色为绿色。
将标签2的BackStyle属性设为fmBackStyleTransparent，使标签2的背景为透明，并把它们的Caption属性全部设置为空白。
        步骤3，将窗体和控件调整为合适的大小，如图所示。

       步骤4，在VBE中双击窗体，写入下面的代码。

  Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Const GWL_STYLE As Long = (-16)
  Private Const GWL_EXSTYLE = (-20)
  Private Const WS_CAPTION As Long = &HC00000
  Private Sub UserForm_Initialize()
      Dim IStyle As Long
      Dim Hwnd As Long
      If Val(Application.Version) < 9 Then
          Hwnd = FindWindow("ThunderXFrame", Me.Caption)
      Else
          Hwnd = FindWindow("ThunderDFrame", Me.Caption)
      End If
      IStyle = GetWindowLong(Hwnd, GWL_STYLE)
      IStyle = IStyle And Not WS_CAPTION
      SetWindowLong Hwnd, GWL_STYLE, IStyle
      DrawMenuBar Hwnd
      UserForm1.Height = 28
  End Sub
       窗体的初始化事件，在窗体加载时使用API函数去除其标题栏。
        第1行到第7行代码，API函数的声明。
        第11行到第15行代码，获取窗口句柄。
        第16行到第19行代码，去除窗体标题栏。
        第20行代码，设置窗体的高度。
        步骤5，在工作表中添加一个命令按钮，双击后写入下面的代码。

  Private Sub CommandButton1_Click()
      Dim n As Integer
      Dim i As Integer
      n = 10000
      With UserForm1
          .Show 0
          For i = 1 To n
              Cells(i, 1) = i
              .Label1.Width = i / n * .Frame1.Width
              .Label2.Caption = "已完成" & Round(i / n * 100, 0) & "%"
              .Label2.Left = .Label1.Width - 50
              DoEvents
          Next
      End With
      Unload UserForm1
      Range("A1:A" & n).ClearContents
  End Sub
       工作表中命令按钮的单击事件，在给工作表A1到A10000单元格赋值的同时使用进度条显示其运行速度。
        第4行代码，设置循环最大值，可根据实际需要设置。
        第6行代码，使用Show方法显示窗体，并且设置为无模式的。
        第8行代码，在单元格中进行无意义的填充数据以演示进度条。
        第9行代码，根据程序运行程度动态设置标签1的宽度，使之达到进度条的效果。
        第10行代码，标签2显示已完成百分比。
        第11行代码，根据标签1的宽度动态设置标签2的Left属性，使已完成百分比跟随标签1移动。
        第12行代码，使用DoEvents函数转让控制权。
DoEvents函数将控制权传给操作系统。
当操作系统处理完队列中的事件，并且在 SendKeys队列中的所有键也都已送出之后，返回控制权。
如果不使用DoEvents函数转让控制权，进度条不能正常显示。
        第15行代码，使用Unload 语句卸载窗体。
        单击工作表中的命令按钮，填充单元格并显示进度条，如图所示。
       

第8部分 控件与用户窗体
技巧134 使用TreeView控件显示层次 TreeView控件是一个树形结构的控件，该控件用于显示分层数据，如目录或文件目录，使程序的表现更为灵活，用户的操作更加方便，示例代码如下：
  Private Sub UserForm_Initialize()
      Dim c As Integer
      Dim r As Integer
      Dim rng As Variant
      rng = Sheet1.UsedRange
      With Me.TreeView1
          .Style = tvwTreelinesPlusMinusPictureText
          .LineStyle = tvwRootLines
          .CheckBoxes = False
          With .Nodes
              .Clear
              .Add Key:="科目", Text:="科目名称"
              For c = 1 To Sheet1.UsedRange.Columns.Count
                  For r = 2 To Sheet1.UsedRange.Rows.Count
                      If Not IsEmpty(rng(r, c)) Then
                          If c = 1 Then
                            .Add relative:="科目", relationship:=tvwChild, Key:=rng(r, c), Text:=rng(r, c)
                          ElseIf Not IsEmpty(rng(r, c - 1)) Then
                            .Add relative:=rng(r, c - 1), relationship:=tvwChild, Key:=rng(r, c), Text:=rng(r, c)
                          Else
                            .Add relative:=CStr(Sheet1.Cells(r, c - 1).End(xlUp)), relationship:=tvwChild, Key:=rng(r, c), Text:=rng(r, c)
                          End If
                      End If
                  Next
              Next
          End With
      End With
  End Sub
       在窗体初始化时将工作表中的科目名称填充TreeView控件。
        第7行代码，设置TreeView控件每个列表的组成方式。
Style属性设置值如表格所示。
               第8行代码，设置TreeView控件显示根节点连线。
TreeView控件的LineStyle属性设置为tvwRootLines显示根节点连线，设置为tvwTreeLines则隐藏根节点连线。
        第9行代码，设置TreeView控件不显示复选框。
        第10行代码使用Nodes属性返回对TreeView控件的Node对象的集合的引用。
        第11行代码，清除TreeView控件所有的节点。
        第12行代码，使用Add方法在Treeview控件的Nodes集合中添加一个Node对象。
，Add方法语法如下： object.Add(relative, relationship, key, text, image, selectedimage) 参数Object是必需的，一个有效的对象。
        参数Relative是可选的，代表已存在的Node对象的索引号或键值。
        参数relationship是可选的，代表新节点与已存在的节点间的关系，指定的Node对象的相对位置。
relationship的设置值如表格所示。
               参数key是可选的，唯一的字符串，可用于用Item方法检索Node。
        参数text 是必需的，在Node中出现的字符串。
        参数image是可选的，代表一个图像或在ImageList控件中图象的索引。
        参数selectedimage是可选的，代表一个图像或在ImageList控件中图象的索引，在 Node被选中时显示。
        第13行到第25行代码代，在根节点下添加子节点。
添加子节点仍然使用Add方法，需要一个唯一的Key值，必须提供根节点的Key值（参数relative）和参数relationship值（tvwChild）。
要将子节点链接到根节点的下面，参数relative必须与根节点的Key值一致，参数relationship必须设置为tvwchild。
要使子节点有效，子节点必须也有自已唯一的Key值。
        获得双击TreeView控件后的返回值的代码如下：
  Private Sub TreeView1_DblClick()
      If TreeView1.SelectedItem.Children = 0 Then
          Sheet1.Range("A65536").End(xlUp).Offset(1) = TreeView1.SelectedItem.Text
      Else
          MsgBox "所选择的不是末级科目,请重新选择科目!"
      End If
  End Sub
       第2行代码判断所选节点是否是末级科目。
TreeView控件的SelectedItem属性返回当前所选择的节点，而Children属性检查所选节点是否还有子节点，如没有子节点则返回0。
        运行窗体效果如图所示。
       

1

征婚启事
请教老师: 1 、 "将ListView控件的View属性设置为lvwReport，以报表视图模式显示"中,想点图标后整行选中,代码怎么写? 2、我把老师例中的代码和控件复到我的工作簿上怎么运行时，提示“变量未定义”见我上传的文件，请老师指教？
1、设置Listview控件的FullRowSelect属性为True，可以选择整行。
 2、VBE中工具---引用。

一直关注！ 不知道最后出版齐全，yuanzhuping 君有没有具体时间表。

还没有具体的时间安排，尽量抓紧吧，争取早日完成。

大致还有15天？1月？或者3月到半年？
真的很佩服你，抛开学术，就你的意志就令人敬佩。

呵呵，真的还没有具体的时间，主要是时间安排上，不能保证，毕竟还要工作、生活。
在前面多次有朋友说上传完整的Word文档方便大家下载，我只能说这个可以有，但是现在真没有。
只有已完成部分的，大家可以到2楼以下的各部分链接中找下下载的楼层。
 现在大概已完成了2/3，估计还要2个月左右。

第8部分 控件与用户窗体
技巧135 用户窗体添加图标 用户窗体在显示时标题栏上是没有图标的，如果希望在窗体上添加图标，可以借助API函数在窗体显示时添加自定义的图标。
        在VBE窗口中单击菜单“插入”→“用户窗体”，插入一个窗体，在窗体中添加一个Image控件，设置Image控件Picture属性为自定义图标的位图，并将Image控件的Visible属性设置为False，使窗体运行时隐藏Image控件，如图所示。

       在VBE中双击窗体，写入下面的代码。

  Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Const WM_SETICON = &H80
  Private Const ICON_SMALL = 0&
  Private Const ICON_BIG = 1&
  Sub ChangeIcon(ByVal hWnd As Long, Optional ByVal hicon As Long = 0&)
      SendMessage hWnd, WM_SETICON, ICON_SMALL, ByVal hicon
      SendMessage hWnd, WM_SETICON, ICON_BIG, ByVal hicon
      DrawMenuBar hWnd
  End Sub
  Private Sub UserForm_Initialize()
      Dim hWnd As Long
      hWnd = FindWindow(vbNullString, Me.Caption)
      Call ChangeIcon(hWnd, Image1.Picture.Handle)
  End Sub
       窗体的初始化事件，窗体在显示时运行ChangeIcon函数，在标题栏中添加图标。
        第1行到第6行代码， API函数声明。
        第7行到第11行代码，ChangeIcon过程，用于转换图标。
        第14行代码，获得窗口句柄。
        第15行代码，运行ChangeIcon过程，将Image控件中的位图显示在窗体的标题栏上。
        运行窗体后，在窗体标题栏上添加图标，如图所示。

第8部分 控件与用户窗体
技巧136 用户窗体添加最大最小化按纽 VBA中的窗体标题栏上只有关闭按纽，没有最大最小化按纽的，可以使用API函数在窗体的标题栏上添加最大最小化按纽，如下面的代码所示。

  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Const WS_MAXIMIZEBOX = &H10000
  Private Const WS_MINIMIZEBOX = &H20000
  Private Const GWL_STYLE = (-16)
  Private Sub UserForm_Initialize()
      Dim hWndForm As Long
      Dim iStyle As Long
      hWndForm = FindWindow("ThunderDFrame", Me.Caption)
      iStyle = GetWindowLong(hWndForm, GWL_STYLE)
      iStyle = iStyle Or WS_MINIMIZEBOX
      iStyle = iStyle Or WS_MAXIMIZEBOX
      SetWindowLong hWndForm, GWL_STYLE, iStyle
  End Sub
       窗体初始化时使用API函数在标题栏上添加最大最小化按纽。
        第1行到第6行代码，API函数声明。
        第10行代码，获取窗口句柄。
        第11行到第14行代码，在标题栏上添加最大最小化按纽。
        运行窗体后效果如图所示。

第8部分 控件与用户窗体
技巧137 禁用窗体标题栏的关闭按钮 如果不希望用户通过窗体标题栏的关闭命令来关闭窗体，可以禁用窗体标题栏上的关闭按钮，如下面的代码所示。

  Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
      If CloseMode <> 1 Then
          Cancel = True
          MsgBox "请点击按钮关闭窗体!"
      End If
  End Sub
       窗体的QueryClose事件，禁用窗体标题栏上的关闭按钮。
        窗体的QueryClose事件发生在窗体关闭之前，语法如下： Private Sub UserForm_QueryClose(cancel As Integer, closemode As Integer) 参数Cance是可选的，整数。
将此参数设置成 0 以外的任意值，在所有加载的用户窗体中停止QueryClose事件，并防止关闭窗体与应用程序。
        参数closemode是可选的，一个值或常数，用来指示引起QueryClose事件的原因。
        closemode参数的设置值如表格所示。
               第2、3行代码，如果窗体不是由代码调用Unload语句关闭，则停止关闭过程，从而禁用窗体标题栏的关闭按钮。
        需要注意的是，一定要在窗体上设置关闭窗体的途径，否则会使窗体无法关闭。
        窗体运行后，禁用窗体上的关闭按钮关闭窗体，只能使用按钮关闭窗体，如图所示。
       
很不好意思,还要麻烦老师,不好意思了,请教: 1、ListView1控制运行后的列宽调整是哪个属性控制的? 2、能否实现，第一列不能调整，其它都能调整？ 3、使第一例不能编辑？ 万分感谢！
ListView控件的列宽调整用Width属性，如第一列：ListView1.ColumnHeaders(1).Width = 100 将ListView控件的LabelEdit属性设置为lvwManual，标签不能编辑。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=26
第8部分 控件与用户窗体
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧138 屏蔽窗体标题栏的关闭按钮 使用API函数可以屏蔽窗体标题栏的关闭按钮，如下面的代码所示。

  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
  Private Const GWL_STYLE = (-16)
  Private Const WS_SYSMENU = &H80000
  Private Hwnd As Long
  Private Sub UserForm_Initialize()
      Dim Istype As Long
      Hwnd = FindWindow("ThunderDFrame", Me.Caption)
      Istype = GetWindowLong(Hwnd, GWL_STYLE)
      Istype = Istype And Not WS_SYSMENU
      SetWindowLong Hwnd, GWL_STYLE, Istype
      DrawMenuBar Hwnd
  End Sub
       第1行到第7行代码是API函数声明。
        第8行到第15行代码是窗体的Initialize事件，当窗体显示时屏蔽窗体标题栏的关闭按钮。
        窗体运行后，屏蔽窗体上的关闭按钮，只能使用按钮关闭窗体，如图所示。
       
第8部分 控件与用户窗体
技巧139 无标题栏和边框的窗体 如果希望制作无标题栏和边框的窗体，那么可以使用API函数。
        在VBE窗口中单击菜单“插入”→“用户窗体”，双击窗体，在其代码窗口中输入下面的代码：
  Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Const GWL_STYLE As Long = (-16)
  Private Const GWL_EXSTYLE = (-20)
  Private Const WS_CAPTION As Long = &HC00000
  Private Const WS_EX_DLGMODALFRAME = &H1&
  Private Sub UserForm_Initialize()
      Dim IStyle As Long
      Dim Hwnd As Long
      If Val(Application.Version) < 9 Then
          Hwnd = FindWindow("ThunderXFrame", Me.Caption)
      Else
          Hwnd = FindWindow("ThunderDFrame", Me.Caption)
      End If
      IStyle = GetWindowLong(Hwnd, GWL_STYLE)
      IStyle = IStyle And Not WS_CAPTION
      SetWindowLong Hwnd, GWL_STYLE, IStyle
      DrawMenuBar Hwnd
      IStyle = GetWindowLong(Hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
      SetWindowLong Hwnd, GWL_EXSTYLE, IStyle
  End Sub
  Private Sub UserForm_Click()
      Unload Me
  End Sub
       窗体初始化时使用API函数去除其标题栏和边框。
        第1行到第8行代码，API函数的声明。
        第12行到第16行代码，获取窗口句柄。
        第17行到第20行代码，去除窗体标题栏。
        第21、22行代码，去除窗体边框。
        第24行到第26行代码，窗体的单击事件，单击窗体后关闭该窗体。
        窗体运行后如图所示，单击后关闭该窗体。
       
第8部分 控件与用户窗体
技巧140 制作年月选择窗体 在工作表中需要输入日期时，可以使用日期时间控件（Microsoft Date and Time Picker Control 6.0，简称DTP控件），请参阅技巧116 。
但有时只需要输入年份和月份，使用DTP控件选择月份并不方便，此时可以使用文本框结合微调框做一个年月选择窗体供用户输入年份和月份。
        步骤1，在VBE窗口中单击菜单“插入”→“用户窗体”，将窗体的Caption属性设置为“请选择年月”。
        步骤2，在窗体上添加一个框架控件和两个命令按纽控件。
在框架控件中添加两个文本框控件和两个SpinButton控件，并把命令按纽的Caption属性分别设置为“确定”和“取消”。
        步骤3，调整好控件位置，双击窗体写入下面的代码。

  Private Sub UserForm_Initialize()
      SpinButton1.Value = Year(Date)
      SpinButton2.Value = Month(Date)
      TextBox1.Text = Year(Date) & "年"
      TextBox2.Text = Month(Date) & "月份"
  End Sub
  Private Sub SpinButton1_Change()
      TextBox1.Text = SpinButton1.Value & "年"
  End Sub
  Private Sub SpinButton2_Change()
      With SpinButton2
          Select Case .Value
              Case 1 To 12
                  TextBox2.Text = .Value & "月份"
              Case Is > 12
                  TextBox1.Text = Left(TextBox1.Text, 4) + 1 & "年"
                  .Value = 1
              Case Is < 1
                  TextBox1.Text = Left(TextBox1.Text, 4) - 1 & "年"
                  .Value = 12
          End Select
      End With
  End Sub
  Private Sub CommandButton1_Click()
      Sheet1.Range("A65536").End(xlUp).Offset(1) = TextBox1.Text & TextBox2.Text
  End Sub
  Private Sub CommandButton2_Click()
      Unload Me
  End Sub
       第1行到第6行代码，窗体的初始化事件，在窗体加载时设置文本框和微调框的初始值。
        第2行代码，设置微调框1的初始值为当前年份。
Year函数返回年份的整数，语法如下： Year(date) 参数date是必需的，可以是任何能够表示日期的Variant、数值表达式、字符串表达式或它们的组合。
        第3行代码，设置微调框2的初始值为当前月份。
Mont函数返回值为1到12之间的整数，表示一年中的某月，语法如下： Month(date) 参数date与Year函数的参数date相同。
        第4行代码，设置文本框1显示的文本为当前年份。
        第5行代码，设置文本框2显示的文本为当前月份。
        第7行到第9行代码，微调框1的Change事件过程。
当单击微调框1数值调节钮的向上键或向下键调节年份时，文本框1显示的年份等于调节后的年份。
        第10行到第23行代码，微调框2的Change事件过程。
当单击微调框2数值调节钮的向上键或向下键调节月份时，文本框2显示的月份等于调节后的月份。
如果是一年以内的调节，只调节文本框2显示的月份，否则还需要调节文本框1显示的年份。
        第25行代码，“确定”按钮的单击过程，将选择好的年月写入工作表中。
        第28行代码，使用Unload 语句卸载窗体。
        运行窗体后效果如图所示。
       
第8部分 控件与用户窗体
技巧141 自定义窗体中的鼠标指针类型 使用对象的MousePointer属性可以自定义鼠标掠过窗体控件时的指针类型，如下面的代码所示。

  Private Sub UserForm_Initialize()
      With Me.TextBox1
          .MousePointer = 99
          .MouseIcon = LoadPicture(ThisWorkbook.Path & "\myMouse.ico")
      End With
  End Sub
       当用户把鼠标放到窗体的文本框上时，所显示的鼠标指针的类型为自定义图标。
        第3行代码设置文本框的MousePointer属性。
MousePointer属性指定当用户把鼠标放到特定对象上时，所显示鼠标指针的类型，语法如下： object.MousePointer [= fmMousePointer] 参数object是必需的，一个有效对象。
         参数fmMousePointer是可选的，所需鼠标指针的形状。
fmMousePointer的设置值如表格所示。
                      第3行代码将文本框的MousePointer属性设置为99，使用由MouseIcon属性指定的自定义图标。
MouseIcon属性为对象指定一个自定义的图标，语法如下： object.MouseIcon = LoadPicture( pathname ) 参数object是必需的，一个有效的对象。
        参数pathname是必需的，指定包含自定义图标的文件的路径和文件名。
        设置后的鼠标指针的形状如图所示。
       
第8部分 控件与用户窗体
技巧142 调整窗体的显示位置 用户窗体显示时，默认的位置是窗体所在Excel文件的中央。
如果需要调整，可以在窗体加载时对其进行设置，如下面的代码所示。

  Private Sub UserForm_Initialize()
      With Me
          .StartUpPosition = 0
          .Left = 500
          .Top = 300
      End With
  End Sub
       窗体的初始化事件，在窗体加载时设置其显示位置。
        第3行代码，将窗体的StartUpPosition属性设置成手动。
        StartUpPosition属性返回或设置一个值，用来指定窗体第一次出现时的位置，设置值如表格所示。
               StartUpPosition属性可以在程序中设置，也可以在窗体的属性窗口中设置。
        第4、5行代码，设置窗体的Left属性和Top属性，使其加载时显示在屏幕的右下角。
        经过设置后的窗体加载时显示位置如图所示。

袁版主：您好！ 请问一下：窗体显示在工作表中的初始位置，除了设置“StartUpPosition属性为0-手动、1-所有者中心、2-屏幕中心、3-窗口缺省”外。
可不可以按照自己的意愿设置呀？如位于焦点的正下方！谢谢！
技巧143 由鼠标确定窗体显示位置 窗体加载时其显示位置还可以由鼠标的坐标来确定，如下面的代码所示。

  Private Sub CommandButton1_Click()
      Dim ActiveCellX As Integer
      Dim ActiveCellY As Integer
      ActiveCellX = ExecuteExcel4Macro("GET.CELL(44)")
      ActiveCellY = ExecuteExcel4Macro("GET.CELL(43)")
      With UserForm1
          .Show 0
          .Top = ActiveCellY
          .Left = ActiveCellX
      End With
  End Sub
       使用ExecuteExcel4Macro方法执行Microsoft Excel 4.0 宏函数取得鼠标的坐标，ExecuteExcel4Macro方法的语法如下： expression.ExecuteExcel4Macro(String) expression参数是可选的，返回一个Application对象。
        String参数是必需的，一个不带等号的Microsoft Excel 4.0宏语言函数。
        第4行代码使用GET.CELL(44) 宏函数取得鼠标的X坐标，第5行代码使用GET.CELL(43) 宏函数取得鼠标的Y坐标。
        第6行到第10行代码显示窗体并设置其Top属性和Left属性，调整其显示的位置。
        还可以利用工作表SelectionChange事件的Target参数取得鼠标的坐标，如下面的代码所示。
   Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      With UserForm1
          .Show 0
          .Top = Target.Top
          .Left = Target.Left
      End With
  End Sub
       工作表的SelectionChange事件过程，Target参数代表新选定的区域，返回一个Range对象，在显示窗体时取得其Top和Left属性后设置窗体显示的Top和Left属性。

点评
jsxjd
似乎无法精确定位

2

征婚启事
龙城飞将III
第8部分 控件与用户窗体
技巧144 用户窗体的打印 在使用如图 144 1所示的窗体录入数据时，如果需要把窗体打印出来，可以使用PrintForm方法，如下面的代码所示。

  Private Sub CommandButton7_Click()
      Dim myHeight As Integer
      Application.ScreenUpdating = False
      With UserForm1
          myHeight = .Height
          .DTPicker1.Visible = False
          .Frame1.Visible = False
          .Height = myHeight - 30
          .PrintForm
          .Height = myHeight
          .DTPicker1.Visible = True
          .Frame1.Visible = True
      End With
      Application.ScreenUpdating = True
  End Sub
       录入窗体中的“打印”按钮的单击代码，使用PrintForm方法打印窗体。
        第5行代码使用变量myHeight记录窗体的Height属性值，以便在第10行代码中恢复窗体原有的高度。
        第6、7行代码将窗体中的DTP日历控件和功能按钮的Visible属性设置为False，使之隐藏，这样在打印时就不会被打印出来。
        第9行代码使用PrintForm方法打印窗体，PrintForm方法将UserForm对象的图象逐位发送到打印机，语法如下： object.PrintForm 参数object代表对象表达式，其值为“应用于”列表中的对象。
如果省略该参数，则把焦点所在的窗体当做object。
 第11、12行代码重新显示窗体中的DTP日历控件和功能按钮。
        窗体打印后的效果如图所示。

 

1

征婚启事
谢谢老师: 我的第二个问题的意思是:当窗体弹出后,让第一列的宽度不能在窗体上变动,其它的列还是可以调整? 如果这样实现不了的话,全部不能调整应该可以的吧? 谢谢指导! 另外请老师把改变光标中的手写字.cur文件贴上分享好吗?
好像没有办法使列的宽度不能调整，找不到相应的属性。

改变光标中的手写字，文件夹中有一个文件的。

第8部分 控件与用户窗体
技巧145 使用自定义颜色设置窗体颜色 在用VBA进行设计时，会发现控件与颜色相关的属性中系统提供可选择的颜色太少。
比如窗体的BackColor属性，如果需要把窗体的背景颜色设置为淡蓝色RGB(52,150,203)，可以在窗体初始化过程中对之进行设置，可以实现想要的效果，但是在设计时却不能看到最终效果。
        其实窗体的BackColor属性（包括ForeColor以及BorderColor等等这些设置颜色的属性）允许输入一个以十六进制表示的长整型数值，这样在设计时就看到效果。
        首先获取所需要的颜色值并以十六进制表示。
还以上面的颜色为例，在立即窗口输入“? Hex(RGB(52,150,203))”可得到一个十六进制数据CB9634，然后把光标定位在窗体属性窗口的BackColor属性值中，删除原来的数值后，输入“&HCB9634&”后按<Enter>键，窗体颜色效果立即就出现了，如图所示。

袁版主：您好！ 本人在技巧140的窗体中加了“天数”旋转控件SpinButton3。
则： 相关代码修改如下： Private Sub UserForm_Initialize() SpinButton1.Value = Year(Date) SpinButton2.Value = Month(Dat ...
你那个SpinButton3是拷贝那月份的吧？在控件的属性窗口修改max属性为31，min属性为0。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=27
本帖已被收录到知识树中，索引项：开发帮助和教程
谢谢版主: 碰到一个很头痛的问题,我在自己搞的一个程序中,想套用版主老师的Listview控件,不知怎么搞的,出现一个怪现现象:那个有宏的工作簿,用代码登陆打不开,但只要先禁用宏打开一下,关闭后,再用代码登陆就能 ...
不清楚怎么会这样，上传附件看看。

DTP控件没正确注册？窗体中有个时间日期控件，请参阅http://club.excelhome.net/viewth ... ;page=73#pid2705819

第8部分 控件与用户窗体
技巧146 在窗体中显示图表 工作表中的图表是不能直接显示在窗体中的，如果需要在窗体上显示图表，除了使用技巧61 介绍的使用ShowWindow属性将工作表中嵌入的图表显示在独立的窗口中，还可以使用以下的方法。

146-1 使用Export方法

可以把图表以图形格式从工作表中导出，再用窗体上的Image控件把图表显示出来，如下面的代码所示。

  Private Sub UserForm_Initialize()
      Dim Charts As Chart
      Dim cName As String
      Set Charts = Sheets("Sheet2").ChartObjects(1).Chart
      cName = ThisWorkbook.Path & "\Temp.gif"
      Charts.Export Filename:=cName, FilterName:="GIF"
      Image1.Picture = LoadPicture(cName)
    End Sub
       窗体的初始化事件过程，窗体加载时将工作表中的图表显示在窗体中。
        第4行到第6行代码，使用Export方法把Sheet2表中的第一个图表导出到工作簿的同一目录下。
        Export方法以图形格式导出图表，语法如下： expression.Export(Filename, FilterName, Interactive) 参数expression是必需的，一个有效的对象。
        参数Filename是必需的，导出的文件的名称。
        本例中设置Filename参数时加上了导出路径，将图形导出到同一文件夹下。
        参数FilterName是可选的，导出文件的格式。
        第7行代码，设置窗体中Image控件的Picture属性为导出文件的完整路径。
        Picture 属性指定显示在对象上的位图，语法如下： object.Picture = LoadPicture( pathname ) 参数expression是必需的，一个有效的对象。
        参数pathname是必需的，一个图片文件的完整路径。
        为了使窗体关闭时删除导出的图片文件，在窗体的QueryClose事件中写入下面的代码。

  Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
      Kill ThisWorkbook.Path & "\Temp.gif"
  End Sub
       窗体关闭时使用Kill方法删除导出的图片文件。
Kill方法的语法如下： Kill pathname 参数Pathname是必需的，用来指定一个文件名的字符串表达式。
Pathname参数可以包含目录或文件夹、以及驱动器。
        运行窗体，将工作表的图表显示在窗体中，如图所示。
        

146-2 使用API函数

可以使用API函数把图表从工作表中导出，再用窗体上的Image控件把图表显示出来，如下面的代码所示。

  Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
  Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long ………代码略详见附件
  Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
  Public Function LoadShapePicture(shp As Object) As IPictureDisp
      Dim nClipsize As Long
      Dim hMem As Long
      Dim lpData As Long
      Dim sdata() As Byte
      Dim fmt As Long
      Dim fmtName As String
      Dim iClipBoardFormatNumber As Long
      Dim IID_IPicture(15) ……代码略详见附件
      EmptyClipboard
      CloseClipboard
  End Function
   Private Sub UserForm_Initialize()
      Image1.Picture = LoadShapePicture(Sheet1.ChartObjects(1))
  End Sub
       第1行到第12行代码API函数声明。
        第13行到第60行代码LoadShapePicture函数，导出工作表中的图表。
        第61行到第63行代码窗体的初始化事件过程，窗体加载时将工作表中的图表显示在窗体中，如图所示。
关于Image 控件的Picture属性请参阅技巧146-1。
       
第8部分 控件与用户窗体
技巧147 窗体运行时调整控件大小 用户窗体中的控件在运行时是不能调整大小的，而在某些情况下需要在窗体运行时调整控件的大小，此时可以利用控件的MouseMove事件。
        步骤1，在VBE窗口中单击菜单“插入”→“用户窗体”，在窗体中添加两个框架控件，在框架控件中间添加一个Image控件，如图所示。
               步骤2，Image控件是用来在窗体运行时拖动调整框架控件大小的，所以需要在Image控件的属性窗口将BackStyle属性设置为fmBackStyleTransparent，使控件的背景为透明；将BorderStyle属性设置为fmBorderStyleNone，使控件无可见的边框线；MousePointer属性设置为fmMousePointerSizeWE，当用户把鼠标放到Image控件上时，鼠标指针的类型为东西向的双箭头。
关于控件的MousePointer属性请参阅技巧141。
        步骤3，在窗体中调整好控件的位置后双击Image控件写入下面的代码：
  Dim Abscissa As Single
  Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
      Abscissa = x
  End Sub
  Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
      If Button = 1 Then
          If Abscissa - x > Frame1.Width Or x > Frame2.Width Then Exit Sub
          Frame1.Width = Frame1.Width - Abscissa + x
          Image1.Left = Image1.Left - Abscissa + x
          Frame2.Left = Frame2.Left - Abscissa + x
          Frame2.Width = Frame2.Width + Abscissa - x
      End If
  End Sub
       第2行到第4行代码，Image控件的MouseDown事件过程，用户按下鼠标按键时发生，语法如下：
Private Sub object_MouseDown( ByVal Button As fmButton, ByVal Shift As fmShiftState, ByVal X As Single, ByVal Y As Single) 其中参数x是可选的，控件位置的横坐标，以磅为单位，从左边开始测量。
        第3行代码将控件的横坐标赋给变量Abscissa。
        第5行到第12行代码，Image控件的MouseMove事件过程，用户移动鼠标时该事件发生，语法如下：
Private Sub object_MouseMove( ByVal Button As fmButton, ByVal Shift As fmShiftState, ByVal X As Single, ByVal Y As Single) 其中参数Button是必需的，标识鼠标按键状态的整数值，其设置值如表格所示。
               参数x是可选的，控件位置的水平坐标，以磅为单位，从左边开始测量。
        在MouseMove事件过程中，当用户在窗体上按下左键移动鼠标时，调整两个框架控件的Width属性和框架2的Left属性，使其达到窗体运行时可以进行拖动调整大小的效果。
        当鼠标指针在对象上移动时，MouseMove事件是连续发生的，只要鼠标位于对象的边界之内，对象就会不断的识别MouseMove事件，所以框架控件可以连续的进行拖动调整大小。
        运行窗体的，选择两个框架控件的中间位置，当鼠标指针变成东西向的双箭头时按下鼠标左键拖动可以进行拖动调整框架控件的大小，如图所示。
       
楼主，什么时候能够下载完整的文件啊？？
http://club.excelhome.net/viewth ... ;page=94#pid2774766 936楼
第8部分 控件与用户窗体
技巧148 在用户窗体上添加菜单 在VBA中，用户窗体上是没有菜单的，为了使用方便，我们可以使用API函数在用户窗体上添加菜单，示例代码如下：
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
  Private Declare Function CreateMenu Lib "user32" () As Long
  Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
  Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
  Private Declare Function CreatePopupMenu Lib "user32" () As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Const GWL_WNDPROC = (-4)
  Private Const MF_STRING = &H0&
  Private Const MF_POPUP = &H10&
  Private Const MF_SEPARATOR = &H800&
  Dim MenuWnd As Long, Dump As Long, PopupMenuID As Long, PopupMenuWnd As Long, MenuID As Long
  Private Sub UserForm_Initialize()
      If Val(Application.Version) < 9 Then
          hwnd = FindWindow("ThunderXFrame", Me.Caption)
      Else
          hwnd = FindWindow("ThunderDFrame", Me.Caption)
      End If
      MenuWnd = CreateMenu()
      PopupMenuID = CreatePopupMenu()
      Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "系统设置(&X)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 100, "保存(&S)...")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 101, "备份(&E)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 102, "退出(&X)")
      PopupMenuID = CreatePopupMenu()
      Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "会计凭证(&P)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 110, "录入(&L)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 111, "审核(&C)")
      PopupMenuID = CreatePopupMenu()
      Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "会计账簿(&Z)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 112, "记账(&T)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 113, "结账(&J)")
      PopupMenuID = CreatePopupMenu()
      Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "会计报表(&B)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 114, "资产负债表(&F)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 115, "损益表(&Y)")
      Dump = SetMenu(hwnd, MenuWnd)
      PreWinProc = GetWindowLong(hwnd, GWL_WNDPROC)
      SetWindowLong hwnd, GWL_WNDPROC, AddressOf MsgProcess
  End Sub
  Private Sub UserForm_Terminate()
      DestroyMenu MenuWnd
      DestroyMenu PopupMenuID
      DestroyMenu PopupMenuWnd
      SetWindowLong hwnd, GWL_WNDPROC, PreWinProc
  End Sub
       第1行到第13行代码，API函数声明。
        第14行到第41代码，用户窗体的Initialize事件过程，在窗体显示时使用API函数在窗体上添加菜单。
其中第22行代码添加第一个“系统设置”菜单，第23、24、25行代码在“系统设置”菜单中添加三个子菜单，第26行代码往下继续添加其他菜单。
        第40行代码，为窗体中添加的菜单指定所执行的过程名称为“MsgProcess”函数过程。
        第42行到第47行代码，用户窗体的Terminate事件过程，将所有引用对象的变量设置成Nothing，从而删除对象的所有引用。
        为了能够使用窗体中添加的菜单，需要在模块中写入下面的代码：
  Public PreWinProc As Long, hwnd As Long
  Public Declare Function CheckMenuRadioItem Lib "user32" (ByVal hMenu As Long, ByVal un1 As Long, ByVal un2 As Long, ByVal un3 As Long, ByVal un4 As Long) As Long
  Public Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
  Public Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
  Public Const MF_UNCHECKED = &H0&
  Public Const MF_CHECKED = &H8&
  Public Const MF_DISABLED = &H2&
  Public Const MF_GRAYED = &H1&
  Public Const MF_ENABLED = &H0&
  Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
  Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
  Private Const MF_BYCOMMAND = &H0&
  Public Function MsgProcess(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
      Dim SubMenu_hWnd As Long
      Select Case wParam
          Case 100
              MsgBox "你选择的是""保存""按钮!"
          Case 101
              MsgBox "你选择的是""备份""按钮!"
          Case 102
              Unload UserForm1
          Case 110
              MsgBox "你选择的是""录入""按钮!"
          Case 111
              MsgBox "你选择的是""审核""按钮!"
          Case 112
              MsgBox "你选择的是""记账""按钮!"
          Case 113
              MsgBox "你选择的是""结账""按钮!"
          Case 114
              MsgBox "你选择的是""资产负债表""按钮!"
          Case 115
              MsgBox "你选择的是""损益表""按钮!"
          Case Else
              MsgProcess = CallWindowProc(PreWinProc, hwnd, Msg, wParam, lParam)
      End Select
  End Function
       第1行到第13行代码，API函数声明。
        第14行到第36行代码，MsgProcess函数过程，根据参数wParam的值为窗体中的菜单指定所执行的操作，为了演示方便只使用MsgBox函数显示一个消息框，在实际应用中可以为菜单写入代码或指定过程名称。
        运行窗体后在窗体上添加菜单，如图所示。
       
第8部分 控件与用户窗体
技巧149 在用户窗体上添加工具栏 在技巧148 中我们在用户窗体上使用API函数添加了菜单，还可以在用户窗体上继续添加工具栏用以显示一列下拉菜单的位图按钮，单击一个工具栏按钮等于选择一个菜单命令，以提供对常用功能和命令的快速访问。
        在用户窗体上添加工具栏可以使用Toolbar控件，在设计模式下右键单击“工具箱”，在显示的右键菜单中选择“附加控件”，在显示的对话框中选择“Microsoft Toolbar Control， veision 6.0”控件，在用户窗体上添加一个Toolbar控件。
如图所示。
               因为需要在Toolbar控件按钮中使用图标，所以还需要在用户窗体中添加一个ImageList控件保存所需要的图像文件，在ImageList控件的属性页中插入6张图片，如图所示。
               用户窗体上添加了Toolbar控件后还需要设置其属性和添加按钮控件，可以在Toolbar控件的属性页中进行设置和添加，如所图示。
               还可以在代码运行时对其进行设置和添加按钮，双击用户窗体写入下面的代码：
  Private Sub UserForm_Initialize()
      ……使用API函数添加菜单代码略，详见附件
      Dim arr As Variant
      Dim i As Byte
      arr = Array(" 录入 ", " 审核", " 记账 ", " 结账 ", "负债表", "损益表")
      With Toolbar1
          .ImageList = ImageList1
          .Appearance = ccFlat
          .BorderStyle = ccNone
          .TextAlignment = tbrTextAlignBottom
          With .Buttons
              .Add(1, , "").Style = tbrPlaceholder
              For i = 0 To UBound(arr)
                  .Add(i + 2, , , , i + 1).Caption = arr(i)
              Next
          End With
      End With
  End Sub
       第5行代码数组arr用来保存按钮的标题文字。
        第7行代码建立Toolbar控件和ImageList控件的关联。
        第8行代码设置Toolbar控件的外观效果，Appearance属性获得或设置控件的外观效果，设置值如表格所示。
               第9行代码设置Toolbar控件的边界样式，BorderStyle属性获得或设置边界样式，设置值如表格所示。
               第10行代码设置按钮文本显示在按钮图像下方，TextAlignment属性获得或设置一个值，决定按钮文本显示在按钮图像下方还是右侧，设置值如表格所示。
               第11行到第15行代码在Toolbar控件中添加按钮，添加按钮需要在Buttons的集合对象中使用Add方法，语法如下： object.Buttons.Add(index, key, caption, style, image) 参数object是必需的，代表Toolbar对象。
       参数index是可选的，指定新增按钮的索引值，该索引值决定了按钮在Toolbar控件中的位置。
如果省略index参数新增按钮添加到Butons集合的最后。
        参数key是可选的，指定新增按钮的关键字。
        参数caption是可选的，指定新增按钮的标题文本。
        参数style是可选的，指定新增按钮的Style属性，设置值如表格所示。
               参数image是可选的，指定新增按钮载入的图像，图像必须是与该Toolbar控件相关联的ImageList控件图像库中的一个。
image参数可以是一个整数，对应ImageList图像库中某个图片的Index值也可以是一个字符串，对应图片的关键字Key。
        第12行代码代码首先在Toolbar控件中添加占位按钮，设置其style属性为tbrPlaceholder，添加的就是占位按钮，在Toolbar控件中是不显示的，仅仅起到占位的作用。
        第14行代码在占位按钮后继续添加6个按钮，设置其标题文本和图像在ImageList控件中的编号。
        为了响应Toolbar控件，双击Toolbar控件写入下面的代码：
  Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
      Select Case Button.Index
          Case 2
              MsgBox "录入"
          Case 3
              MsgBox "审核"
          Case 4
              MsgBox "记账"
          Case 5
              MsgBox "结账"
          Case 6
              MsgBox "资产负债表"
          Case 7
              MsgBox "损益表"
      End Select
  End Sub
       Toolbar控件的ButtonClick事件，在单击Toolbar控件的按钮时发生，参数Button代表单击的按钮。
为了演示方便，根据其Index属性值使用消息框显示按钮标题文本，在实际应用中可以为菜单写入代码或指定过程名称。
        运行窗体后在窗体上添加工具栏，如图所示。
       

请问：为何不能添加ActiveX控件呀？但添加窗体控件却可以。
之前本人在此工作表中添加过DTP控件，但现在添加其他ActiveX控件却不行了。
到底是怎么回事呀？谢谢！
VBE中工具>引用，看看有没有丢失什么引用，2007的我没用过。

老师在948楼介绍的无框窗体,实际上有一白边,上次看到有位老师的例题是完全没边的,不知老师有代码? 谢谢!
我的没有呀，请看图。

第8部分 控件与用户窗体
技巧150 使用代码添加窗体及控件 VBA中的用户窗体为用户提供了可视化的操作界面，在用户窗体中一般都包含控件以便与用户进行交互。
我们通常是在VBE中使用菜单“插入”→“用户窗体”来创建用户窗体，然后拖动工具箱中的控件到用户窗体中，也可以使用代码来添加用户窗体及其控件，代码如下：
  Private Sub CommandButton1_Click()
      Dim myForm As VBComponent
      Dim myTextBox As Control
      Dim myButton As Control
      Dim i As Integer
      Set myForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
      With myForm
          .Properties("Name") = "Formtest"
          .Properties("Caption") = "演示窗体"
          .Properties("Height") = "180"
          .Properties("Width") = "240"
          Set myTextBox = .Designer.Controls.Add("Forms.CommandButton.1")
          With myTextBox
              .Name = "myTextBox"
              .Caption = "新建文本框"
              .Top = 40
              .Left = 138
              .Height = 20
              .Width = 70
          End With
          Set myButton = .Designer.Controls.Add("Forms.CommandButton.1")
          With myButton
              .Name = "myButton"
              .Caption = "删除文本框"
              .Top = 70
              .Left = 138
              .Height = 20
              .Width = 70
          End With
          With .CodeModule
              i = .CreateEventProc("Click", "myTextBox")
              .ReplaceLine i + 1, Space(4) & "Dim myTextBox As Control" & Chr(10) & Space(4) & "Dim i As Integer" & Chr(10) & Space(4) & "Dim k As Integer" _
                  & Chr(10) & Space(4) & "k = 10" & Chr(10) & Space(4) & "For i = 1 To 5" & Chr(10) & Space(8) & "Set myTextBox = Me.Controls.Add(bstrprogid:=""Forms.TextBox.1"")" _
                  & Chr(10) & Space(8) & "With myTextBox" & Chr(10) & Space(12) & ".Name = ""myTextBox"" & i" & Chr(10) & Space(12) & ".Left = 20" _
                  & Chr(10) & Space(12) & ".Top = k" & Chr(10) & Space(12) & ".Height = 18" & Chr(10) & Space(12) & ".Width = 80" _
                  & Chr(10) & Space(12) & "k = .Top + 28" & Chr(10) & Space(8) & "End With" & Chr(10) & Space(4) & "Next"
              i = .CreateEventProc("Click", "myButton")
              .ReplaceLine i + 1, Space(4) & "Dim i As Integer" & Chr(10) & Space(4) & "On Error Resume Next" & Chr(10) & Space(4) & "For i = 1 To 5" & Chr(10) & Space(8) & "Formtest.Controls.Remove ""myTextBox"" & i" & Chr(10) & Space(4) & "Next"
          End With
      End With
  End Sub
       使用代码添加一个用户窗体及其两个按钮控件，并为按钮控件添加单击事件及其相应的代码。
        第2行到第5行代码声明变量类型，如果发生错误请在菜单“工具”→“引用”中引用“Microsoft Visual Basic for Applications Extensibility 5.3”，如图所示。
               第6行代码，使用Add方法添加用户窗体，应用于VBComponents集合的Add方法将一个对象添加到集合，语法如下： object.Add(component) 参数object是必需的，一个有效的对象名。
        参数component是必需的，对于VBComponents集合，则为表示类模块、窗体、标准模块的列举常数，可以为表格所示的常量之一。
               第8行到第11行代码，使用VBComponent对象的Properties属性设置用户窗体的相关属性。
        第12行代码，使用Add方法添加在用户窗体上添加一个按钮控件。
VBComponent对象的Designer属性返回一个设计器对象，其Controls属性返回Controls集合，代表用户窗体中所有的控件。
应用于Controls集合对象的Add方法在用户窗体中添加控件，语法如下： object.Add( ProgID [, Name [, Visible]]) 参数object是必需的，一个有效的对象名。
        参数ProgID是必需的，程序设计标识符。
是用于标识对象类的、没有空格的文本串。
关于程序设计标识符请参阅技巧119-3中的表格。
        参数Name是可选的，指定被添加的对象的名称。
        参数Visible是可选的，若对象为可见的为True，若对象为隐藏的则为False。
默认值为True。
        第13行到第20行代码设置添加的按钮控件的相关属性。
        第21行到第29行代码继续添加一个按钮控件并设置其相关属性。
        第30行到第40行代码为添加的按钮控件创建单击事件过程并在其单击事件中添加代码。
        其中第30、39行代码使用CreateEventProc方法为按钮控件创建单击事件过程，应用于CodeModule对象的CreateEventProc方法创建一个事件过程，语法如下： object.CreateEventProc(eventname, objectname) As Long 参数object是必需的，一个有效的对象名。
        参数eventname是必需的，字符串表达式，用来指定欲添加到模块的事件名称。
        参数objectname是必需的，字符串表达式，用来指定事件源的对象名称。
        CreateEventProc方法可返回事件过程的开始行，所以使用变量i保存开始行。
        第32行代码使用ReplaceLine方法在按钮控件的单击事件过程中添加代码，应用于CodeModule对象的ReplaceLine方法用特定的代码代替原代码，语法如下： object.ReplaceLine(line, code) 参数object是必需的，一个有效的对象名。
        参数line是必需的，用来指定所要代替的行。
        参数code是必需的，用来指定要插入的代码。
        在使用ReplaceLine方法时将line参数设置为变量i加1，也就是在单击事件过程的第2行开始添加代码，在添加代码时使用Space函数插入空格，使用Chr函数进行换行。
        运行CommandButton1_Click过程，添加一个用户窗体及两个按钮控件，并在用户窗体中添加以下的代码：
  Private Sub myTextBox_Click()
      Dim myTextBox As Control
      Dim i As Integer
      Dim k As Integer
      k = 10
      For i = 1 To 5
          Set myTextBox = Me.Controls.Add("Forms.TextBox.1")
          With myTextBox
              .Name = "myTextBox" & i
              .Left = 20
              .Top = k
              .Height = 18
              .Width = 80
              k = .Top + 28
          End With
      Next
  End Sub
  Private Sub myButton_Click()
      Dim i As Integer
      On Error Resume Next
      For i = 1 To 5
          Formtest.Controls.Remove "myTextBox" & i
      Next
  End Sub
       第1行到第17行代码，用户窗体中“新建文本框”按钮的单击事件，在用户窗体运行时使用Add方法在用户窗体中添加5个文本框控件并设置其相关属性。
        第18行到第24行代码，用户窗体中“删除文本框”按钮的单击事件，在用户窗体运行时使用Remove方法删除文本框控件。
应用于Controls集合的Remove方法从集合中删除一个成员，或者从框架、页面或窗体中删除一个控件，语法如下： object.Remove( collectionindex) 参数object是必需的，一个有效的对象名。
        参数collectionindex是必需的，成员在集合内的位置或索引。
        注意 Remove方法只能删除在运行时间添加的控件，如果想删除在设计时间添加的控件则会出错。
        运行CommandButton1_Click过程添加的用户窗体如图所示。
               单击“添加文本框”按钮在用户窗体中添加5个文本框控件，如图所示，而单击“删除文本框”按钮则删除用户窗体中添加的文本框控件。
       

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=28
本帖已被收录到知识树中，索引项：开发帮助和教程
从开贴到第8部分的完成，不行不觉的已有三个多月了，现在发现每天更新真的好累，决定给自己放几天假，第9部分从星期一开始更新，可能速度要慢点了（呵呵，我把贴子标题也改了 ）。

 

 

 

求教： 技巧149中 ， ImageList控件的属性页，Toolbar控件的属性页， 如何打开，找不到啊。

http://club.excelhome.net/viewth ... ;page=90#pid2763455 892楼中有ImageList控件的内容。

第8部分 控件与用户窗体
继续更新，本来第8部分已经结束，想想还有几个技巧也不错，还是整理了一下，Word文档等第9部分结束时一起更新吧。

技巧151 用户窗体的全屏显示 在需要用户窗体全屏显示时，可以将窗体的Height属性和Width属性设置为一定的数值，使之显示时和显示器一样大小。
        使用这种方法虽然可以达到全屏显示的要求，但是如果换台显示器不一样的电脑时，此种方法便会失效。
为了使用户窗体达到真正的全屏显示，可以使用以下的方法。

151-1 设置用户窗体为应用程序的大小

将用户窗体的高度和宽度设置为应用程序的高度和宽度，如下面的代码所示。

  Private Sub UserForm_Initialize()
      Application.WindowState = xlMaximized
      With Me
          .Width = Application.Width
          .Height = Application.Height
          .Left = Application.Left
          .Top = Application.Top
      End With
  End Sub
       用户窗体初始化时，将高度和宽度设置成与Excel应用程序窗口一样。
        第2行代码，将Excel应用程序的WindowState属性设置为xlMaximized，使Excel应用程序最大化显示。
        不使用对象识别符时Application属性返回一个Application对象，代表Excel应用程序。
WindowState属性返回或设置窗口的状态，可以为表格所示的XlWindowState常量之一。
               第3行到第8行代码将用户窗体的Width属性、Height属性设置为Excel应用程序的高度和宽度。
Width属性、Height属性以磅为单位返回或设置对象的高度和宽度，将用户窗体的Left属性、Top属性设置为和最大化后的Excel应用程序的一样。

151-2 根据屏幕分辨率进行设置

根据屏幕分辨率的大小自动调整用户窗体的高度和宽度，如下面的代码所示。

  Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  Const SM_CXSCREEN As Long = 0
  Const SM_CYSCREEN As Long = 1
  Private Sub UserForm_Initialize()
      With Me
          .Height = GetSystemMetrics(SM_CYSCREEN) * 0.72
          .Width = GetSystemMetrics(SM_CXSCREEN) * 0.75
          .Left = 0
          .Top = 0
      End With
  End Sub
       用户窗体初始化时根据屏幕分辨率的大小自动调整用户窗体的高度和宽度。
        第1行到第3行代码，API函数声明。
        第6行代码设置用户窗体的高度，屏幕分辨率的Y坐标值乘以0.72将其换算成以磅为单位的数值。
        第7行代码设置用户窗体的宽度，屏幕分辨率的X坐标值乘以0.75将其换算成以磅为单位的数值。
        经过以上两种方法的设置，用户窗体显示时始终以全屏显示。

第8部分 控件与用户窗体
技巧152 在用户窗体上添加状态栏 在技巧148 、技巧149 中我们在用户窗体上添加了菜单和工具栏，为了使窗体更像正规的软件，还需要在用户窗体的底部添加一个状态栏，用于显示程序的各种状态信息。
       在用户窗体上添加状态栏使用StatusBar控件，StatusBar控件用于设计窗体状态栏，状态栏由一组连续的窗格（最多16个）对象组合而成，用于显示应用程序当前的工作状态，其位置通常在应用程序窗体的底部。
在设计模式下右键单击“工具箱”，在显示的右键菜单中选择“附加控件”，在如图所示对话框中选择“Microsoft StatusBar Control， veision 6.0”控件，拖动后就可以在用户窗体上添加一个StatusBar控件。
               在用户窗体上添加了StatusBar控件后还需要添加窗格，可以在StatusBar控件的属性页中进行设置和添加，在StatusBar控件的属性窗口中选择“自定义”按钮，在如图所示的属性页中设置属性和添加窗格。
               也可以在代码运行时对其进行属性设置和添加窗格，双击用户窗体写入下面的代码：
  Private Sub UserForm_Initialize()
      ……使用API函数添加菜单代码略，详见附件。

      Dim arr As Variant
      Dim i As Byte
      ……使用Toolbar控件添加工具栏代码略，详见附件。

      arr = Array(0, 6, 5)
      With StatusBar1
          .Width = Me.Width - 10
          For i = 1 To 3
              .Panels.Add(i, , "").Style = arr(i - 1)
          Next
          .Panels(1).Text = "准备就绪!"
          .Panels(2).Width = 60
          .Panels(3).Width = 75
          .Panels(1).Width = Me.Width - .Panels(1).Width - .Panels(2).Width
          .Panels(3).Picture = LoadPicture(ThisWorkbook.Path & "\123.BMP")
          For i = 0 To 2
              .Panels(i + 1).Alignment = i
          Next
      End With
  End Sub
       第8行代码设置StatusBar控件的宽度比用户窗体略小一点。
        第9行到第11行代码在StatusBar控件中添加三个窗格并指定窗格的样式。
添加窗格需要在Panels集合对象中使用Add方法，语法如下： object.Panels.Add(index, key, text, style, picture) 参数object是必需的，代表StatusBar对象。
        参数index是可选的，指定新增窗格的索引值，该索引值决定了窗格在StatusBar控件中的位置。
如果省略index参数新增窗格添加到Panels集合的最后。
        参数key是可选的，指定新增窗格的关键字。
        参数text是可选的，指定新增窗格中显示的文本。
        参数style是可选的，指定新增窗格的样式，设置值如表格所示。
               参数picture是可选的，指定新增窗格载入的图像。
        第12行代码设置第一个窗格显示的文本。
        第13行到第15行代码设置三个窗格的宽度。
        第16行代码为第三个窗格加载指定的图像。
        第17行到第19行代码设置三个窗格中文本的对齐方式。
Panels对象的Alignment属性返回或设置窗格中文本的对齐方式，设置值如表格所示。
               在示例中使用StatusBar控件的第一个窗格在用户窗体的文本框输入时显示所输入的内容，需要在文本框中写入下面的代码。

  Private Sub TextBox1_Change()
      StatusBar1.Panels(1).Text = "正在录入:" & TextBox1.Text
  End Sub
       文本框的Change事件过程，将文本框中输入的内容显示在StatusBar控件的第一个窗格中。
        运行窗体后在窗体上添加状态栏，如图所示。
       
第9部分 函数的使用
技巧153 调用工作表函数求和 在对工作表的单元格区域进行求和计算时，使用工作表Sum函数比使用VBA代码遍历单元格进行累加求和效率要高得多，代码如下所示。

  Sub rngSum()
      Dim rng As Range
      Dim d As Double
      Set rng = Range("A1:F7")
      d = Application.WorksheetFunction.Sum(rng)
      MsgBox rng.Address(0, 0) & "单元格的和为" & d
  End Sub
       rngSum过程调用工作表Sum函数对工作表的单元格区域进行求和计算。
        在VBA中调用工作表函数需要在工作表函数前加上WorksheetFunction属性。
应用于Application对象的WorksheetFunction属性返回WorksheetFunction对象，作为VBA中调用工作表函数的容器，在实际应用中可省略Application对象识别符。

第9部分 函数的使用
技巧154 查找最大、最小值 在VBA中没有内置的函数可以进行最大、最小值的查找，借助工作表Max、Min函数可以快速地在工作表区域中查找最大、最小值，如下面的代码所示。

  Sub seeks()
      Dim rng As Range
      Dim myRng As Range
      Dim k1 As Integer, k2 As Integer
      Dim max As Double, min As Double
      Set myRng = Sheet1.Range("A1:F30")
      For Each rng In myRng
          If rng.Value = WorksheetFunction.max(myRng) Then
              rng.Interior.ColorIndex = 3
              k1 = k1 + 1
              max = rng.Value
          ElseIf rng.Value = WorksheetFunction.min(myRng) Then
              rng.Interior.ColorIndex = 5
              k2 = k2 + 1
              min = rng.Value
          Else
              rng.Interior.ColorIndex = 0
          End If
      Next
      MsgBox "最大值是:" & max & "共有 " & k1 & "个" _
          & Chr(13) & "最小值是:" & min & "共有 " & k2 & "个"
  End Sub
       seeks过程在工作表单元格区域中查找最大、最小值，并将其所在的单元格底色分别设置为红色和蓝色。
        第2行到第5行代码声明变量类型。
        第6行代码使用关键字Set将单元格引用赋给变量myRng。
        第7行到第19行代码遍历单元格区域，使用工作表Max、Min函数判断单元格数值是否是所在区域的最大、最小值，如果是，将其所在的单元格底色设置为红色或蓝色，并保存其数值和数量。
        第20、21行代码使用消息框显示最大、最小值数值和数量。
        运行seeks过程后将工作表区域最大、最小值所在的单元格的底色设置为红色或蓝色并用消息框显示其数值和数量，如图所示。

请问老大，你的VBA常用技巧代码解析大至上目录有多少页，我打算把前面的先打印出来，准备预留目录页出来，不知道留多少
说实话我也不知道会有多少页，后面的有些只写了个技巧名称，有些连技巧名称都没写上去，真的不清楚，如果要打印的话建议还是再等等。

袁版主：您好！ 辛苦了！不好意思，请问一下：本人在运行技巧152时，出现下面附件图片中的错误提示。
是怎么回事呀？谢谢！
附件的文件夹中有一个123.BMP文件，要和Excel文件放在同一文件夹中。

第9部分 函数的使用
技巧155 不重复值的录入 在工作表中录入数据时，有时希望能限制重复值的录入，比如在示例的A列单元格只能录入唯一的人员编号，此时可以利用工作表的Change事件结合工作表的CountIf 函数来判断所录入的人员编号是否重复，示例代码如下。

  Private Sub Worksheet_Change(ByVal Target As Range)
      With Target
          If .Column <> 1 Or .Count > 1 Then Exit Sub
          If Application.CountIf(Range("A:A"), .Value) > 1 Then
              .Select
              MsgBox "不能输入重复的人员编号!", 64
              Application.EnableEvents = False
              .Value = ""
              Application.EnableEvents = True
          End If
      End With
  End Sub
       工作表的Change事件过程，使A列单元格只能录入唯一的人员编号。
       第4行代码使用工作表的CountIf 函数来判断在A列单元格输入的人员编号是否重复。
工作表的CountIf 函数计算区域中满足给定条件的单元格的个数，语法如下： COUNTIF(range, criteria) 参数range为需要计算其中满足条件的单元格数目的单元格区域。
        参数criteria为确定哪些单元格将被计算在内的条件，其形式可以为数字、表达式、单元格引用或文本。
        在示例中以所录入的人员编号与A列单元格区域进行比较，如果CountIf 函数的返回值大于1，说明录入的是重复编号。
        第5行代码，重新选择该单元格便于下一步清空后重新录入。
        第7、8、9行代码，清除录入的重复编号，在清除前将Application对象的EnableEvents属性设置为False，禁用事件。
因为如果不禁用事件，那么在清除重复值的过程中会不断地触发工作表的Change事件，从而造成代码运行的死循环。
        经过以上的设置，在工作表的A列中只能录入唯一的人员编号，如果录入重复值会进行如图所示提示，点击确定后自动清除录入的重复编号。
       
谢谢袁版主！是不是一定要解压后才能打开呀？我是解压后才可能打开的。

附件解压后有个文件夹，有一个Excel文件和一个123.BMP图像文件，运行时要保证两个文件在同一个目录中。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=29
本帖已被收录到知识树中，索引项：开发帮助和教程
袁版主：您好！ 本人按照您介绍的步骤制作了一个关于“禁用宏则关闭工作薄”的工作薄，点击“禁用宏”，出现“该工作薄中包含一种无法禁用的宏（Microsoft Excel 4.0 版的宏），此宏.........”对话框后，点击“ ...
你的附件没有为每个表添加工作表级别的名称“Auto_Activate”，并将引用都指向宏表“Macro1”的A2单元格。
先运行一下队件中的AddPrivateNames过程。
 Sub AddPrivateNames() Dim sht As Object For Each sht In Sheets ThisWorkbook.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False Next End Sub
第9部分 函数的使用
技巧156 获得当月的最后一天 在实际工作中经常需要根据给定的日期计算其所属月份的最后一天，此时可以使用DateSerial函数完成计算，如下面的代码所示。

  Sub Serial()
      Dim DateStr As Byte
      DateStr = Day(DateSerial(Year(Date), Month(Date) + 1, 0))
      MsgBox "本月的最后一天是" & Month(Date) & "月" & DateStr & "号"
  End Sub
       Serial过程配合使用了4个VBA内置函数Year、Month、Day和DateSerial完成计算并使用消息框显示当月最后一天的日期。
        Year、Month和Day函数分别返回代表指定日期的年、月、日的整数，语法如下： Year(Date) Month(Date) Day(Date) 其中参数Date可以是任何能够表示日期的Variant、数值表达式、字符串表达式或它们的组合。
        DateSerial函数返回包含指定的年、月、日的Variant (Date)，语法如下： DateSerial(year, month, day) 其中参数year、 month、day分别表示指定的年、月、日。
        为了指定某个日期， DateSerial 函数中的每个参数的取值范围应该是可接受的，即日的取值范围应在1-31之间，而月的取值范围应在1-12之间。
但是，当一个数值表达式表示某日之前或其后的年、月、日数时，也可以为每个使用这个数值表达式的参数指定相对日期。
当任何一个参数的取值超出可接受的范围时，它会自动地在可接受的时间单位进行调整，例如本例中的day参数设置为0，则被解释成month参数指定月的前一天，即表达式Month(Date) + 1指定的下一个月的前一天，也就是本月的最后一天。
        运行Serial过程结果如图所示。
       

1

征婚启事
第9部分 函数的使用
技巧157 四舍五入运算 在实际工作中经常需要对数值或计算结果进行四舍五入运算，此时可以使用VBA内置的Round函数。
Round函数返回一个数值，该数值是按照指定的小数位数进行四舍五入运算的结果，语法如下： Round(expression [,numdecimalplaces]) 参数expression是必需的，要进行四舍五入运算的数值表达式。
        参数numdecimalplaces是可选的，数字值，表示进行四舍五入运算时，小数点右边应保留的位数。
如果忽略，则Round函数返回整数。
        但是VBA内置的Round函数在对数值进行四舍五入运算时实行的是Bankre舍入，而不是算术舍入。
按Bankre舍入规则，如果保留位数的下一个数字正好是5则其后没有其他有效数字，则按保留位最后一位“偶舍奇入”的方法进行处理。
比如Round(1.5)的保留位最后为1，是奇数，小数位的5入上去，因此Round(1.5)的运算结果是2；而Round(4.5)的保留位最后为4，是偶数，小数位的5舍去，因此Round(4.5) 的运算结果是4而不是5。
        Bankre舍入规则虽然有其合理性，但不符合实际工作的需要。
在实际应用中使用以下两种方法避免Bankre舍入：

157-1 极小值修正法

在使用Round函数时对需要舍入的数值先加上极小值再调用VBA内置的Round函数，如下面的代码所示。

  Sub aTestRound()
      MsgBox "Round(4.5)=" & Round(4.5) & Chr(13) & "Round(4.5)=" & Round(4.5 + 0.0000001)
  End Sub
       aTestRound过程分别调用VBA内置的Round函数和加上极小值再调用VBA内置的Round函数在洗染店框中显示两者运算结果，如图所示。
               从运算结果中可以发现，加上极小值后Round(4.5)已正确运算为5而不是4。

157-2 调用工作表函数法

还可以使用工作表函数Round代替VBA内置的Round函数。
工作表函数Round和VBA内置的Round函数的用法相同，但它采用算术舍入而不是Bankre舍入，所以不会有“偶舍奇入”的问题，如下面的代码所示。

  Sub bTestRound()
      MsgBox "Round(4.5)=" & Round(4.5) & Chr(13) & "Round(4.5)=" & Application.Round(4.5, 0)
  End Sub
       bTestRound过程分别调用VBA内置的Round函数和工作表Round函数在消息框中显示两者运算结果，如图所示。
               从运算结果中可以发现，使用工作表Round函数后Round(4.5)已正确运算为5而不是4。

 

第9部分 函数的使用
技巧158 使用字符串函数 使用VBA的字符串函数可以对字符串进行各种操作，如下面的代码所示。

  Sub StrFunctions()
      Dim Str As String
      Str = "AbcD EFG hijk Lmn"
      MsgBox "原始字符串为：" & Str & Chr(13) _
          & "字符串长度为：" & Len(Str) & Chr(13) _
          & "左边8个字符为：" & Left(Str, 8) & Chr(13) _
          & "右边6个字符为：" & Right(Str, 6) & Chr(13) _
          & "从左边第2个开始取5个字符为：" & Mid(Str, 2, 5) & Chr(13) _
          & "转换为大写：" & UCase(Str) & Chr(13) _
          & "转换为小写：" & LCase(Str) & Chr(13)
  End Sub
       StrFunctions过程使用字符串函数对字符串进行各种操作，如计算字符数、取得一定数量的字符、大小写转换等。
        第5行代码使用Len函数返回字符串内字符的数目，Len函数语法如下： Len(string | varname) 参数string为任何有效的字符串表达式。
        参数varname为任何有效的变量名称。
        两个可能的参数必须有一个，而且只能有一个参数。
        第6行代码使用Left函数从字符串左边起返回8个字符。
        第7行代码使用Right函数从字符串右边起返回6个字符 Left函数语法如下：
Left(string, length) Right函数语法如下：
Right(string, length) 参数string是必需的，字符串表达式。
        参数length是必需的，数值表达式，将返回的字符数量。
如果为0，返回零长度字符串 ("")；如果大于或等于参数string的字符数，则返回整个字符串。
        第8行代码使用Mid函数从字符串第2位起返回5个字符。
Mid函数语法如下：
Mid(string, start[, length]) 参数string是必需的，字符串表达式。
        参数start是必需的，string中被取出部分的字符位置。
如果超过string的字符数，将返回零长度字符串 ("")。
        参数length是可选的，要返回的字符数。
如果省略或超过string的字符数，将返回字符串中所有字符。
        第9行代码使用UCase函数将字符串转换成大写的字符串。
        第10行代码使用LCase函数将字符串转换成小写的字符串。
        UCase函数的语法如下： UCase(string) LCase函数的语法如下： LCase(string) 参数string是必需的，任何有效的字符串表达式。
        运行StrFunctions过程结果如图所示。
       
第9部分 函数的使用
技巧159 使用日期函数 使用VBA的日期函数可以对日期进行各种计算，如下面的代码所示。

  Sub DatFunctions()
      Dim Str As String
      Dim Week As String
      Str = InputBox("请输入日期：")
      If Len(Str) > 0 Then
          If IsDate(Str) Then
              Select Case Weekday(Str, vbMonday)
                  Case 1
                      Week = "一"
                  Case 2
                      Week = "二"
                  Case 3
                      Week = "三"
                  Case 4
                      Week = "四"
                  Case 5
                      Week = "五"
                  Case 6
                      Week = "六"
                  Case 7
                      Week = "日"
              End Select
              MsgBox "你输入的日期是" & DateValue(Str) & Chr(13) _
                  & "是" & Year(Str) & "年的第" & DatePart("q", Str) & "季度" & Chr(13) _
                  & "是星期" & Week & Chr(13) _
                  & "距离今天有" & Abs(DateDiff("d", Date, Str)) & "天" & Chr(13) _
                  & "60天后的日期是" & DateAdd("d", 60, Str)
          Else
              MsgBox "请输入正确格式的日期!"
          End If
      End If
  End Sub
       DatFunctions过程在对话框中输入日期后使用各种日期函数对其进行计算并用消息框显示。
        第4、5行代码使用InputBox函数显示一个对话框，供用户在对话框中输入一个日期。
        第6行代码使用IsDate函数判断输入的日期是否正确。
IsDate函数返回Boolean值，指出一个表达式是否可以转换成日期，语法如下： IsDate(expression) 参数expression是必需的，日期表达式或字符串表达式，如果表达式是一个日期，或者可以作为有效日期识别，则IsDate函数返回True，否则返回False。
        第7行到第22行代码使用Weekday函数判断所输入的日期是星期几。
Weekday函数返回一个整数，代表某个日期是星期几，语法如下： Weekday(date, [firstdayofweek]) 参数date是必需的，能够表示日期的 Variant、数值表达式、字符串表达式或它们的组合。
        参数firstdayofweek是可选的，指定一星期第一天的常数，如表格所示。
               Weekday函数返回一个1到7之间的整数，当firstdayofweek参数设置为vbMonday（2）时，返回1时说明是星期一，以此类推。
        第23行代码根据系统中指定的短日期格式来显示所输入的日期。
DateValue函数的语法如下： DateValue(date) 参数date是必需的，任何表达式，表示从 100 年 1 月 1 日到 9999 年 12 月 31 日之间的一个日期。
如果是一个字符串，且其内容只有数字以及分隔数字的日期分隔符，则 DateValue函数就会根据系统中指定的短日期格式来识别月、日、年的顺序。
DateValue函数也识别明确的英文月份名称，全名或缩写均可。
例如，除了12/30/1991 和12/30/91 之外，DateValue函数也能识别December 30, 1991 和Dec 30, 1991。
        如果date参数中略去了年这一部分，DateValue函数就会使用由计算机系统日期设置的当前年份。
        第24行代码判断输入的日期的季度。
DatePart函数返回一个包含已知日期的指定时间部分的值，语法如下： DatePart(interval, date[,firstdayofweek[, firstweekofyear]]) 其中参数interval是必需的，字符串表达式，是要返回的时间间隔，设定值如表格所示。
               第26行代码计算所输入的日期距当天的天数。
DateDiff函数返回两个指定日期间的时间间隔数目，语法如下： DateDiff(interval, date1, date2[, firstdayofweek[, firstweekofyear]]) 其中参数interval是必需的，字符串表达式，表示用来计算date1和date2的时间差的时间间隔，设定值如以上表格 所示。
        参数date1和date2是必需的，计算中要用到的两个日期。
        因为如果输入的日期是当前日期以前的日期，DateDiff函数会返回负值，所以使用Abs函数返回绝对值将其转换为正值。
        第27行代码计算所输入的日期距当天的天数，DateAdd返回加上了一段时间间隔的一个日期，语法如下： DateAdd(interval, number, date) 参数interval是必需的，字符串表达式，是所要加上去的时间间隔，设定值如以上表格所示。
        参数number是必需的，是要加上的时间间隔的数目。
其数值可以为正数（得到未来的日期），也可以为负数（得到过去的日期）。
        参数date是必需的，需要加上时间间隔的字符串表达式。
        运行DatFunctions过程，在显示的对话框中输入一个日期，结果如图所示。
       
斑竹，哪个选中区域自动重算的代码我复制后直接打开查看代码然后黏贴上去，结果测试了不行啊，是哪个环节出错了？
不是有附件的吗？是从贴子中直接

点击以后到102页了
是有这情况，好像有时相差10页，应该是论坛的问题。
 比如现在的118和119页是一样的。

第9部分 函数的使用
技巧160 判断是否为数值 使用IsNumeric函数可以判断表达式的运算结果是否为数值，如下面的代码所示。

  Sub Numeric()
      Dim i As Integer
      Dim n As String
      Dim s As String
      With Sheet1
          For i = 1 To .Range("A65536").End(xlUp).Row
              If IsNumeric(.Cells(i, 1)) Then
                  n = n & .Cells(i, 1).Address(0, 0) & Chr(9) & .Cells(i, 1) & Chr(13)
              Else
                  s = s & .Cells(i, 1).Address(0, 0) & Chr(9) & .Cells(i, 1) & Chr(13)
              End If
          Next
      End With
      MsgBox "A列中数值单元格：" & Chr(13) & n & Chr(13) _
          & "A列中非数值单元格：" & Chr(13) & s
  End Sub
       Numeric过程使用IsNumeric函数判断工作表的A列单元格是否为数值，并使用消息框显示。
        第7行代码判断工作表的A列单元格是否为数值。
IsNumeric函数返回Boolean值，指出表达式的运算结果是否为数，语法如下： IsNumeric(expression) 参数expression是必需的，Variant类型，包含数值表达式或字符串表达式。
        如果参数expression的运算结果为数字，则IsNumeric返回True，否则返回False。
        第8行代码将数值单元格的地址和数值保存在变量 e中。
        第10行代码将非数值单元格的地址和内容保存在变量 s中。
在保存时插入制表符对数据列进行分隔，使之排列整齐，请参阅技巧73-5。
        运行Numeric过程结果如图所示。
       
第9部分 函数的使用
技巧161 格式化数值、日期和时间 Format函数是VBA中的常用函数，可以实现数值、日期和时间格式的转变，示例代码如下：
  Sub FromatCurrent()
      MsgBox Format(123456.789, "0.00") & Chr(13) _
          & Format(123456.789, "0.00%") & Chr(13) _
          & Format(123456.789, "##,##0.00") & Chr(13) _
          & Format(-123456.789, "$#,##0.00;($#,##0.00)") & Chr(13) _
          & Format(-123456.789, "￥#,##0.00;(￥#,##0.00)") & Chr(13) _
          & Format(Date, "yyyy-mm-dd") & Chr(13) _
          & Format(Date, "yyyymmdd") & Chr(13) _
          & Format(Date, "Long Date") & Chr(13) _
          & Format(Now, "hh:mm:ss") & Chr(13) _
          & Format(Now, "hh:mm:ss AMPM")
  End Sub
       FromatCurrent过程使用消息框显示格式化后的数值、日期和时间。
        Format函数根据格式表达式中的指令来格式化的数值、日期和时间，语法如下： Format(expression[, format[, firstdayofweek[, firstweekofyear]]]) 其中参数expression是必需的，任何有效的表达式。
        参数format是可选的，有效的命名表达式或用户自定义格式表达式。
        第2行代码将数值格式化为两位小数格式显示。
        第3行代码将数值格式化为两位小数的百分比格式显示。
        第4行代码将数值格式化为千位分隔符显示。
        第5行代码将数值格式化为以美元符号显示的两位小数，以千位分隔符分隔，如果是负值则以小括号显示。
        第6行代码将数值格式化为以人民币符号显示的两位小数，以千位分隔符分隔，如果是负值则以小括号显示。
        第7行代码将系统日期格式化为“yyyy-mm-dd”格式显示。
        第8行代码将系统日期格式化为“yyyymmdd”格式显示。
        第9行代码将系统日期格式化为长日期格式显示。
        第10行代码将系统时间格式化为24小时、分钟和秒的格式显示。
        第11行代码将系统时间格式化为分12小时、分钟和秒的格式显示。
        运行FromatCurrent过程结果如图所示。
       

1

龙城飞将III
第9部分 函数的使用
技巧162 计算个人所得税 在财务工作中经常需要计算个人所得税，而在Excel中并没有计算个人所得税的函数，此时可以使用自定义函数来计算，如下面的代码所示。

  Public Function PITax(Income, Optional Threshold) As Single
      Dim Rate As Single
      Dim Debit As Single
      Dim Taxliability As Single
      If IsMissing(Threshold) Then Threshold = 2000
      Taxliability = Income - Threshold
      Select Case Taxliability
          Case 0 To 500
              Rate = 0.05
              Debit = 0
          Case 500.01 To 2000
              Rate = 0.1
              Debit = 25
          Case 2000.01 To 5000
              Rate = 0.15
              Debit = 125
          Case 5000.01 To 20000
              Rate = 0.2
              Debit = 375
          Case 20000.01 To 40000
              Rate = 0.25
              Debit = 1375
          Case 40000.01 To 60000
              Rate = 0.3
              Debit = 3375
          Case 60000.01 To 80000
              Rate = 0.35
              Debit = 6375
          Case 80000.01 To 10000
              Rate = 0.4
              Debit = 10375
          Case Else
              Rate = 0.45
              Debit = 15375
      End Select
      If Taxliability <= 0 Then
          PITax = 0
      Else
          PITax = Application.Round(Taxliability * Rate - Debit, 2)
      End If
  End Function
       自定义PITax函数根据应纳税额计算应纳的个人所得税额。
        第5行代码设置个人所得税的起征点为2000元，如果以后需要调整起征点，可把2000元改为调整后的起征点。
        第6行代码设置应纳税所得额等于应纳税收入减去起征点。
        第7行到第35行代码根据全月应纳税所得额取得税率和速算扣除数。
税率和速算扣除数根据如表格所示的工资、薪金所得适用个人所得税九级超额累进税率表计算。
               第36行到第40行代码根据应纳税所得额、税率和速算扣除数计算应纳的个人所得税额。
其中第39行代码中使用工作表函数Round对计算结果进行四舍五入运算，请参阅技巧157-2。
        在工作表中使用自定义PITax函数结果如图所示。
       
https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=30
第9部分 函数的使用
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧163 人民币大写函数 在VBA中没有内置的函数进行人民币大写转换，此时可以编写自定义函数进行人民币大写转换，如下面的代码所示。

  Public Function RMBDX(M)
      RMBDX = Replace(Application.Text(Round(M + 0.00000001, 2), "[DBnum2]"), ".", "元")
      RMBDX = IIf(Left(Right(RMBDX, 3), 1) = "元", Left(RMBDX, Len(RMBDX) - 1) & "角" & Right(RMBDX, 1) & "分", IIf(Left(Right(RMBDX, 2), 1) = "元", RMBDX & "角整", IIf(RMBDX = "零", "", RMBDX & "元整")))
      RMBDX = Replace(Replace(Replace(Replace(RMBDX, "零元零角", ""), "零元", ""), "零角", "零"), "-", "负")
  End Function
       第2行代码首先使用Round函数对小写数字加上极小值后进行四舍五入运算，关于Round函数请参阅技巧157-1。
其次使用工作表Text函数将数值转换成人民币大写格式表示的文本。
Text函数将数值转换为按指定数字格式表示的文本，语法如下： TEXT(value,format_text) Value参数为数值、计算结果为数值的公式，或对包含数值的单元格的引用。
        Format_text参数为“单元格格式“对话框中”数字“选项卡上”分类框中的文本形式的数字格式。
        最后使用Replace函数将人民币大写格式表示的文本中的小数点替换成“元”。
Replace函数返回一个字符串，该字符串中指定的子字符串已被替换成另一子字符串，并且替换发生的次数也是指定的，语法如下： Replace(expression, find, replace[, start[, count[, compare]]]) 其中参数expression是必需的，包含要替换的子字符串。
        参数find是必需的，要搜索到的子字符串。
        参数replace是必需的，用来替换的子字符串。
        参数start是可选的，在表达式中子字符串搜索的开始位置。
        第3行代码使用了IIF函数、Left函数、Right函数根据第2行代码返回的人民币大写格式表示的文本中的“元”的位置在文本中插入正确的“元”、“角”、“分”字符，使之符合人民币大写习惯。
        IIf函数根据表达式的值，来返回两部分中的其中一个，语法如下： IIf(expr, truepart, falsepart) 参数expr是必需的，用来判断真伪的表达式。
        参数truepart是必需的，如果expr为True，则返回这部分的值或表达式。
        参数falsepart是必需的，如果expr为False，则返回这部分的值或表达式。
        Left、Right函数请参阅技巧158 。
        第4行代码使用Replace函数将人民币大写格式表示的文本中可能出现的“零元零角”、“零元”替换成空白字符；可能出现的“零角”替换成“零”。
如果输入负数的话，将“-”替换成“负”。
        在工作表中使用自定义RMBDX函数转换人民币大写的效果如图所示。
       
第9部分 函数的使用
技巧164 列号转换为列标 使用VBA获取单元格的列号时，只能返回一个数值。
如果需要获取以字符表示的列标，可以使用下面的自定义GetColumn函数过程。

  Function GetColumn(C As Integer) As String
      GetColumn = Split(Cells(1, C).Address, "$")(1)
  End Function
       GetColumn函数过程代码中，将参数iCol作为列号传递给Cells属性，并获取其绝对地址字串符，然后以“$”字符为分隔符，通过Split函数返回一个一维数组。
        Split函数返回一个下标从零开始的一维数组，它包含指定数目的子字符串，语法如下： Split(expression[, delimiter[, limit[, compare]]]) 其中参数expression是必需的，包含子字符串和分隔符的字符串表达式 。
如果expression是一个长度为零的字符串("")，则返回一个空数组，即没有元素和数据的数组。
        参数delimiter是可选的，用于标识子字符串边界的字符串字符。
如果忽略，则使用空格字符(" ")作为分隔符。
        返回一维数组后获取该数组的第2个元素（下标为1），即该列号的字符列标。
        下面的代码使用GetColumn函数过程获得所选单元格的字符列标。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      MsgBox GetColumn(Selection.Column)
  End Sub
      
第9部分 函数的使用
技巧165 判断工作表是否为空表 VBA中没有专门的属性或函数可以判断工作表是否为空白工作表，可以使用自定义函数返回指定工作表是否为空工作表，如下面的代码所示。

  Function IsBlankSht(Sh As Variant) As Boolean
      If TypeName(Sh) = "String" Then Set Sh = Worksheets(Sh)
      If Application.CountA(Sh.UsedRange.Cells) = 0 Then
          IsBlankSht = True
      End If
  End Function
       自定义IsBlankSht函数包含一个Variant变量类型的参数，代表工作表名称或者对象名称。
如果指定的工作表为空工作表，则该函数返回True。
        第2行代码使用TypeName函数判断参数Sh是否为字符串类型（“String”），如果是字符串，则将以该字符串作为名称的工作表赋值给变量Sh。
        第3行代码通过工作表函数CountA统计工作表已使用区域的非空单元格个数，如果统计结果为0，则表示该工作表为空工作表。
        现在就可以像使用VBA函数一样使用自定义的IsBlankSht函数，如下面的代码所示。

  Sub DelBlankSht()
      Dim Sh As Worksheet
      Application.DisplayAlerts = False
      For Each Sh In ThisWorkbook.Sheets
          If IsBlankSht(Sh) Then Sh.Delete
      Next
      Application.DisplayAlerts = True
  End Sub
       使用自定义的IsBlankSht函数删除工作簿中所有空工作表。
        第3行代码将Application对象的DisplayAlerts属性设置为False，使删除时不显示系统警告对话框。
        第4行到第6行代码，使用For Each...Next语句遍历所有工作表，使用自定义的IsBlankSht函数判断是否为空表，如果为空表则使用Delete方法删除。
        注意 自定义IsBlankSht函数仅仅判断工作表单元格区域内容是否为空，如果工作表中存在其它对象（如图形对象、数据有效性、单元格批注等），还需要再进一步判断。

第9部分 函数的使用
技巧166 查找指定工作表 判断工作簿中是否存在指定名称的工作表，除了使用遍历工作簿中所有工作表的方法外，还可以使用自定义函数，如下面的代码所示。

  Function ExistSh(Sh As String) As Boolean
      Dim Sht As Object
      On Error Resume Next
      Set Sht = Sheets(Sh)
      If Err.Number = 0 Then ExistSh = True
      Set Sht = Nothing
  End Function
       自定义ExistSh函数包含一个String类型的参数，代表需要判断的工作表名称。
如果该工作表存在，则返回True。
        第5行代码判断前面的代码是否出错，如果前面的代码存在错误，则表示不存在指定名称的表。
        使用自定义ExistSheet函数判断工作簿中是否存在指定名称的工作表，如下面的代码所示。

  Sub NotSht()
      Dim Sh As String
      Sh = InputBox("请输入工作表名称：")
      If Len(Sh) > 0 Then
          If Not ExistSh(Sh) Then
              MsgBox "对不起," & Sh & "表不存在!"
          Else
              Sheets(Sh).Select
          End If
      End If
  End Sub
       NotSht过程使用自定义的ExistSh函数判断工作簿中是否存在指定名称的工作表，如果不存在则使用消息框进行提示，如图所示。
       
第9部分 函数的使用
技巧167 查找指定工作簿是否打开 如果需要判断指定名称的工作簿是否已经打开，除了使用技巧43 的方法外，还可以使用与技巧166 类似的自定义函数，如下面的代码所示。

  Function ExistWorkbook(WbName As String) As Boolean
      Dim wb As Workbook
      On Error Resume Next
      Set wb = Workbooks(WbName)
      If Err.Number = 0 Then ExistWorkbook = True
      Set wb = Nothing
  End Function
       自定义ExistWorkbook函数判断指定名称的工作簿是否已经打开。
        第5行代码判断前面的赋值语句是否存在错误。
如果没有指定名称的工作簿，则第4行代码会产生错误，自定义ExistWorkbook函数返回False。
        下面使用自定义ExistWorkbook函数判断名称为“Excel Home”的工作簿是否已经打开，如果没有打开则使用消息框进行提示，如图所示。

  Sub NotWorkbook()
      If Not (ExistWorkbook("Excel Home")) Then MsgBox "对不起,Excel Home工作簿没有打开!"
  End Sub

第9部分 函数的使用
技巧168 取得应用程序的安装路径 使用自定义函数取得应用程序的安装路径，如下面的代码所示。

  Function GetSetupPath(AppName As String)
      Dim WSH As Object
      Set WSH = CreateObject("Wscript.Shell")
      GetSetupPath = WSH.RegRead("HKEY_LOCAL_MACHINE\Software" _
          & "\Microsoft\Windows\CurrentVersion\App Paths" _
          & AppName & "\Path")
      Set WSH = Nothing
  End Function

  End Sub
       自定义GetSetupPath函数取得应用程序的安装路径，其中参数AppName代表指定的应用程序的名称。
        第3行代码使用CreateObject函数将Wscript.Shell对象的引用赋给变量WSH。
        CreateObject函数创建并返回一个对ActiveX 对象的引用，语法如下： CreateObject(class,[servername]) 参数class是必需的，Variant (String)，要创建的应用程序名称和类。
        参数servername是可选的，Variant (String)，要在其上创建对象的网络服务器名称。
如果servername是一个空字符串("")，即使用本地机器。
        第4行代码取得AppName参数指定的应用程序在注册表中的路径。
       
请教老师: 1、能只打印窗体中一个框架中的内容吗? 2、打印时背景图案是否同时打印出来的？ 谢谢！
1、在打印时将窗体中其他控件隐藏，打印完毕后显示。
 2、应该可以吧，试一下就知道了。

第9部分 函数的使用
技巧169 数组的使用

169-1 代码运行时创建数组

使用Array函数可以在代码运行时创建数组并把一系列数据保存在数组中，示例代码如下：
  Option Base 1
  Sub arr()
      Dim arr As Variant
      Dim i As Integer
      arr = Array("王晓明", "吴胜玉", "周志国", "曹武伟", "张新发", "卓雪梅", "沈煜婷", "丁林平")
      For i = LBound(arr) To UBound(arr)
          Cells(i, 1) = arr(i)
      Next
  End Sub
       Arr过程使用Array函数创建一个数组用来保存数据并将其写入到工作表的单元格区域。
        第1行代码使用Option Base语句声明数组下标的缺省下界为1，数组下标的缺省下界默认为0。
        第5行代码使用Array函数创建数组用来保存数据。
Array函数返回一个包含数组的Variant，语法如下： Array(arglist) Arglist参数是一个用逗号隔开的值表，这些值用于给Variant所包含的数组的各元素赋值。
如果不提供Arglist参数，则创建一个长度为 0 的数组。
        第6行代码使用LBound函数和UBound函数取得数组的最小和最大下标。
        LBound函数返回一个Long型数据，其值为指定数组维可用的最小下标，语法如下： LBound(arrayname[, dimension]) UBound函数返回一个Long型数据，其值为指定数组维可用的最大下标，语法如下： UBound(arrayname[, dimension]) 参数arrayname是必需的，数组变量的名称。
        参数dimension是可选的，指定返回哪一维的下界，1表示第一维，2表示第二维，如此类推。
默认为1。
        UBound函数与LBound函数一起使用，可以用来确定数组的大小。
        第7行代码确定数组的大小后使用For...Next语句遍历数组元素并将数组元素依次写入到工作表的A列单元格中，如图所示。
        

169-2 文本转换为数组

在处理字符串时可以使用Split 函数将字符串按指定的分隔符分开并以数组返回，代码如下：
  Sub Splitarr()
      Dim Arr As Variant
      Arr = Split(Sheet2.Cells(1, 1), ",")
      Sheet1.Cells(1, 1).Resize(UBound(Arr) + 1, 1) = Application.Transpose(Arr)
  End Sub
       Splitarr过程使用Split 函数将工作表Sheet2中A1单元格的姓名分别写入到工作表Sheet1中的A列单元格。
        Split 函数返回一个下标从零开始的一维数组，包含指定数目的子字符串，语法如下： Split(expression[, delimiter[, limit[, compare]]]) 参数expression是必需的，包含子字符串和分隔符的字符串表达式。
        参数delimiter是必需的，用来标识子字符串边界的字符串字符。
如果忽略，则使用空格字符(" ")作为分隔符。
        第4行代码，首先使用UBound函数取得返回数组的最大下标后调整单元格区域，因为数组下标的缺省下界默认为0，所以在使用Resize属性调整单元格区域时参数RowSize需要在返回数组的最大下标上加一。
        然后使用工作表Transpose函数将返回数组转置后写入到工作表调整后的单元格区域中。
        工作表Transpose函数返回转置单元格区域，即将一行单元格区域转置成一列单元格区域，反之亦然，语法如下： TRANSPOSE(array) 参数array为需要进行转置的数组或工作表中的单元格区域。
        Splitarr过程将如图所示的工作表单元格中的字符串以逗号分隔后依次写入到工作表的A列单元格中。
               

169-3 使用动态数组去除重复值

在技巧169-2中使用数组函数将单元格中的文本进行分隔后写入到工作表Sheet1中的A列单元格，但是如果文本中含有大量的重复值，在写入时也会将重复值写入到工作表中，此时可以使用动态数组去除文本中的重复值，如下面的代码所示。

  Sub Splitarr()
      Dim Splarr() As String
      Dim Arr() As String
      Dim Temp() As String
      Dim r As Integer
      Dim i As Integer
      On Error Resume Next
      Splarr = Split(Sheet2.Range("a1"), ",")
      For i = 0 To UBound(Splarr)
          Temp = Filter(Arr, Splarr(i))
          If UBound(Temp) < 0 Then
              r = r + 1
              ReDim Preserve Arr(1 To r)
              Arr(r) = Splarr(i)
          End If
      Next
      Sheet1.Range("a1").Resize(r, 1) = Application.Transpose(Arr)
  End Sub
       Splitarr过程将工作表Sheet2中A1单元格的文本去除重复值后写入到工作表Sheet1中的A列单元格。
        第2行代码声明数组Splarr用来保存Sheet2中A1单元格的文本。
        第3行代码声明数组Arr用来保存去除重复值后的文本。
        第4行代码声明数组Temp用来判断文本是否重复。
        第5行代码声明变量r用来保存去除重复值后的文本数量。
        第7行代码启动错误处理程序来忽略错误，因为在程序运行到第11行代码会发生下标越界错误。
        第8行代码使用Split 函数以Sheet2中A1单元格的文本创建一个下标从零开始的一维数组。
关于Split 函数请参阅技巧169-2。
        第9行代码使用For...Next语句遍历数组Splarr的所有元素。
        第10行代码使用Filter函数创建一个数组Temp用来保存以当前Splarr数组的值在Arr数组中的搜索结果。
Filter函数返回一个下标从零开始的数组，该数组包含基于指定筛选条件的一个字符串数组的子集，语法如下： Filter(sourcesrray, match[, include[, compare]]) 参数sourcesrray是必需的，要执行搜索的一维字符串数组。
        参数match是必需的，要搜索的字符串。
        参数include是可选的，Boolean值，表示返回子串是否包含match字符串。
如果参数include是True，Filter函数返回的是包含match参数子字符串的数组子集。
如果参数include是False，Filter函数返回的是不包含match参数子字符串的数组子集。
        参数compare是可选的，所使用的字符串比较类型。
        第11行代码根据返回的数组Temp的最大下标来判断当前Splarr数组的值是否重复。
在使用使用Filter函数时如果没有相匹配的值，将返回一个空数组，最大下标小于0。
        第12行代码如果当前Splarr数组的值不重复则将变量r的值加1。
        第13行代码重新定义动态数组大小。
ReDim语句，在过程级别中使用，用于为动态数组变量重新分配存储空间，语法如下： ReDim [Preserve] varname(subscripts) [As type] [, varname(subscripts) [As type]] 参数Preserve是可选的，关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中原来的数据。
        参数varname是必需的，变量的名称。
        参数subscripts是必需的，数组变量的维数，最多可以定义 60 维的多维数组，使用下面的语法； [ lower To] upper [,[lower To] upper] 第14行代码将不重复值添加到数组Arr中。
        第15行代码使用工作表Transpose函数将去除重复值的的文本转置后写入到工作表的A列单元格中。
        如果需要将去除重复值的的文本写入到第一行单元格中，可以将第15行代码改成下面的代码： Sheet1.Range("a1").Resize(1, r) = Arr 如果需要将去除重复值的的文本还是以逗号作为分隔符写入到A1单元格中，可以将第15行代码改成下面的代码： Sheet1.Range("a1") = Join(Arr, ",") Join函数返回一个字符串，该字符串是通过连接某个数组中的多个子字符串而创建的，语法如下： Join(sourcearray[, delimiter]) 参数sourcearray是必需的，包含被连接子字符串的一维数组。
        参数delimiter是可选的，在返回字符串中用于分隔子字符串的字符，如果忽略则使用空格(" ")来分隔子字符串。

点评
jsxjd
第三个“向丽芳”把第十三处“向丽”过滤掉了
1-9部分Word文档

 

 

1-9部分附件

请教版主老师 我这个图标为什么显示不出来
注意图标文件的格式
https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=31
第10部分 文件操作
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧170 导入文本文件 在实际应用中，我们经常从软件中将数据导出为文本文件，在需要将这些文本文件导入到Excel中时可以使用以下的方法。

170-1 使用查询表导入

在Excel VBA中可以使用Add方法新建查询表后导入文本文件，如下面的代码所示。

  Sub AddQuery()
      Sheet1.UsedRange.ClearContents
      With Sheet1.QueryTables.Add( _
          Connection:="TEXT;" & ThisWorkbook.Path & "\工资表.txt", _
          Destination:=Range("A1"))
          .TextFilePlatform = 936
          .TextFileCommaDelimiter = True
          .Refresh
      End With
  End Sub
       AddQuery过程使用QueryTable对象的Add方法新建查询表后将文本文件“工资表.txt”的内容导入到工作表中。
        应用于QueryTable对象的Add方法新建一个查询表，返回QueryTable对象，该对象代表新建的查询表，语法如下： expression.Add(Connection, Destination, Sql) 参数expression是必需的，返回一个QueryTables对象。
        参数Connection是必需的，查询表的数据源。
如果数据源是文本文件，是“TEXT;<文本文件路径和名称>”形式的字符串，其他数据源请参阅帮助。
        参数Destination是必需的，Range类型，查询表目标区域左上角单元格用于放置生成的查询表的区域。
目标区域必须在包含expression 指定的QueryTables对象的工作表上。
        参数Sql是可选的，在ODBC数据源上运行的SQL查询字符串，当将QueryTable对象、文本文件、或是ADO或DAO Recordset对象指定为数据源时不能使用该参数。
        第3行到第5行代码在工作表中建立对位于同一目录中的“工资表.txt”文本文件的查询，并将查询结果放置到工作表中。
        第6行代码设置导入的文本文件的原始格式，QueryTables对象的TextFilePlatform属性返回或设置正向查询表中导入的文本文件的原始格式，默认值是在“文本导入向导”的“文件原始格式”选项中的当前设置。
        第7行代码设置文本文件导入查询表中时，是以逗号作为分隔符。
        第8行代码使用Refresh方法更新外部数据区域，应用于QueryTable对象的Refresh方法更新外部数据区域，语法如下： expression.Refresh(BackgroundQuery) 参数expression是必需的，返回一个QueryTable对象。
        参数BackgroundQuery是可选的的，只用于基于SQL查询结果的QueryTable。

170-2 使用Open

语句导入 使用Open语句输入文本文件，如下面的代码所示。

  Sub OpenText()
      Dim Filename As String
      Dim myText As String
      Dim mArr() As String
      Dim i As Integer
      Dim j As Integer
      Filename = ThisWorkbook.Path & "\工资表.txt"
      j = 1
      Sheet1.UsedRange.ClearContents
      Open Filename For Input As #1
      Do While Not EOF(1)
          Line Input #1, myText
          mArr = Split(myText, ",")
          For i = 0 To UBound(mArr)
              Sheet1.Cells(j, i + 1) = mArr(i)
          Next
          j = j + 1
      Loop
      Close #1
  End Sub
       OpenText过程使用Open语句将文本“工资表.txt”的内容输入到工作表中。
        第10行代码使用Open语句打开文本文件以完成对文本文件的输入。
Open语句能够对文件输入/输出（I/O），语法如下：。
        Open pathname For mode [Access access] [lock] As [#]filenumber [Len=reclength] Pathname是必需的，指定文件名，该文件名可能还包括目录、文件夹及驱动器。
        mode是必需的，指定文件方式，有Append、Binary、Input、Output、或Random方式。
如果未指定方式，则以Random访问方式打开文件。
        Access是可选的，说明打开的文件可以进行的操作，有Read、Write、或Read Write操作。
        lock是可选的，说明限定于其它进程打开的文件的操作，有Shared、Lock Read、Lock Write、和Lock Read Write操作。
        filenumber是必需的，一个有效的文件号，范围在 1 到 511 之间。
使用FreeFile函数可得到下一个可用的文件号。
        reclength是可选的，小于或等于 32，767（字节）的一个数。
对于用随机访问方式打开的文件，该值就是记录长度。
对于顺序文件，该值就是缓冲字符数。
        第11行代码使用Do...Loop 语句重复执行第12行到第17行代码，直到文本文件的结尾。
EOF函数返回一个Integer，它返回Boolean值True，表明已经到达为Random或顺序Input打开的文件结尾，语法如下： EOF(filenumber) 参数filenumber是必需的，是一个Integer，包含任何有效的文件号。
        第12行代码使用Line Input # 语句读入一行数据并将其赋予变量myText。
Line Input # 语句从已打开的顺序文件中读出一行并将它分配给String变量，语法如下： Line Input #filenumber, varname Filenumber是必需的，任何有效的文件号。
        varnamer是必需的，有效的Variant或String变量名。
        第13行代码使用Split函数按逗号作为分隔符分开这行字符，赋值数组mArr。
关于Split函数请参阅技巧169-2。
        第14行到第16行代码将数组mArr循环赋值给单元格，请参阅技巧169-1。
        第19行代码关闭文本文件。
Close语句关闭Open语句所打开的输入/输出 (I/O) 文件，语法如下： Close [filenumberlist] 参数filenumberlist是可选的，为一个或多个文件号，如省略则将关闭所有由Open语句打开的活动文件。

 

第10部分 文件操作
技巧171 将数据写入文本文件 在需要时可以将Excel中的数据写入到文本文件中，有以下方法可以实现。

171-1 使用Print

# 语句 使用Print # 语句将数据写入文本文件中，如下面的代码所示。

  Sub PrintText()
      Dim myFileName As String
      Dim myDataAr() As Variant
      Dim myStr As String
      Dim myRow As Integer
      Dim myCol As Integer
      Dim i As Integer
      Dim j As Integer
      On Error Resume Next
      myFileName = "工资表.txt"
      Kill ThisWorkbook.Path & "" & myFileName
      With Sheet1
          myRow = .Range("A65536").End(xlUp).Row
          myCol = .Range("IV1").End(xlToLeft).Column
          ReDim myDataAr(1 To myRow, 1 To myCol)
          For i = 1 To myRow
              For j = 1 To myCol
                  myDataAr(i, j) = .Cells(i, j).Value
              Next
          Next
          Open ThisWorkbook.Path & "" & myFileName For Output As #1
          For i = 1 To UBound(myDataAr, 1)
              myStr = ""
              For j = 1 To UBound(myDataAr, 2)
                  myStr = myStr & CStr(myDataAr(i, j)) & ","
              Next
              myStr = Left(myStr, (Len(myStr) - 1))
              Print #1, myStr
          Next
          Close #1
      End With
      MsgBox "文件保存成功!"
  End Sub
       PrintText过程将工作表中数据写入到文本文件“工资表.txt”中。
        第11行代码使用Kill方法删除同一目录中可能存在的同名文本文件。
        第13、14行使用单元格的End属性取得工作表中已使用数据的行、列号，关于End属性请参阅技巧3 。
        第15行代码重新定义动态数组myDataAr的大小。
关于动态数组请参阅技巧169-3。
        第16行到第20行代码将工作表数据赋给数组myDataAr。
        第21行代码使用Open语句打开文本文件以完成对文本文件的输入。
关于Open语句请参阅技巧170-2。
        第22行到第29行代码使用Print #语句将数组myDataAr中的所有元素写入到文本文件中。
Print #语句将格式化显示的数据写入顺序文件中，语法如下： Print #filenumber, [outputlist] Filenumber是必需的，任何有效的文件号。
        第30行代码Close语句关闭文本文件。

171-2 另存为文本文件

使用SaveAs方法将工作表另存为文本文件，如下面的代码所示。

  Sub SaveText()
      Dim myFileName As String
      myFileName = "工资表.txt"
      On Error Resume Next
      Kill ThisWorkbook.Path & "" & myFileName
      Application.ScreenUpdating = False
      Worksheets("Sheet1").Copy
      ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path _
          & "" & myFileName, _
          FileFormat:=xlCSV
      MsgBox "文件保存成功!"
      ActiveWorkbook.Close SaveChanges:=False
      Application.ScreenUpdating = True
  End Sub
       SaveText过程将工作表“Sheet1”保存为文本文件。
        第4、5行代码使用Kill方法删除同一目录中可能存在的同名文本文件。
        第7行代码使用Copy方法复制工作表“Sheet1”。
        第8行到第10行代码使用SaveAs方法将文件保存为文本文件。
应用于Workbook对象的SaveAs方法保存对不同文件中的工作表的更改，语法如下：
expression.SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local) 其中参数Filename表示要保存的文件名。
可包含完整路径。
如果不指定路径，Microsoft Excel 将文件保存到当前文件夹中。
        其中参数FileFormat指定保存文件时使用的文件格式，在本例中指定为xlCSV即保存为文本文件。
        第12行代码使用Close方法关闭活动工作簿。

170-3 使用OpenText方法

使用OpenText方法载入一个文本文件并将其作为包含单个工作表的工作簿处理，如下面的代码所示。

  Sub OpenText()
      Dim myFileName As String
      myFileName = "工资表.txt"
      Sheet1.UsedRange.ClearContents
      Workbooks.OpenText _
          Filename:=ThisWorkbook.Path & "" & myFileName, _
          StartRow:=1, DataType:=xlDelimited, Comma:=True
      With ActiveWorkbook
          With .Sheets("工资表").Range("A1").CurrentRegion
              ThisWorkbook.Sheets("Sheet1").Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
          End With
          .Close False
      End With
  End Sub
       OpenText过程使用OpenText方法载入“工资表.txt”文本文件并将其数据写入到工作表中。
        第5行到第7行代码使用OpenText方法载入“工资表.txt”文本文件。
OpenText方法载入一个文本文件，并将其作为包含单个工作表的工作簿进行分列处理，然后在此工作表中放入经过分列处理的文本文件数据，语法如下：
expression.OpenText(FileName, Origin, StartRow, DataType, TextQualifier, ConsecutiveDelimiter, Tab, Semicolon, Comma, Space, Other, OtherChar, FieldInfo, TextVisualLayout, DecimalSeparator, ThousandsSeparator, TrailingMinusNumbers, Local) 其中参数FileName是必需的，指定要载入并作分列处理的文件名称。
        参数StartRow是可选的，作分列处理的起始行号，默认值为 1。
        参数DataType是可选的，在文件中指定数据的列格式。
        参数Comma是可选的，如果该值为True，则将分隔符设为逗号。
        其他参数请参阅VBA中的帮助文档。
        第9行到第11行代码将作为工作表打开的文本文件中的数据写入到工作表中。
        第13行代码使用Close方法关闭打开的文本文件。

 

第10部分 文件操作
技巧172 文件修改的日期和时间 在VBA过程中如果需要获得文件最后修改的日期和时间，可以使用FileDateTime函数，如下面的代码所示。

  Sub myDateTime()
      Dim Stmp As String
      Dim myDateTime As Date
      Stmp = ThisWorkbook.Path & "" & ThisWorkbook.Name
      myDateTime = FileDateTime(Stmp)
      MsgBox Stmp & "最后修改时间是：" & Chr(13) & myDateTime
  End Sub
       myDateTime过程使用消息框显示文件最后修改的日期和时间。
        FileDateTime函数返回一个文件被创建或最后修改后的日期和时间，语法如下： FileDateTime(pathname) pathname 参数是必需的，用来指定文件名的字符串表达式。
pathname 可以包含目录或文件夹、以及驱动器。
        第4行代码使用变量Stmp保存代码所在工作簿的路径和名称。
        第5行代码使用变量myDateTime保存FileDateTime函数返回的日期和时间。
        运行myDateTime过程结果如图所示。

"技巧171 将数据写入文本文件"的附件？
谢谢，在更新技巧170附件时搞错了，现两个附件都已重新上传。

第10部分 文件操作
技巧173 查找文件或文件夹 在磁盘中查找文件或文件夹，可以使用Dir函数，如下面的代码所示。

#DIR

  Sub mydir()
      Dim mydir As String
      Dim b As Byte
      b = 1
      Range("A:A").ClearContents
      mydir = Dir(ThisWorkbook.Path & "\*.xls", vbNormal)
      Do While mydir <> ""
          Cells(b, 1) = mydir
          mydir = Dir
          b = b + 1
      Loop
  End Sub
       Mydir过程使用Dir函数在代码所在工作簿的文件夹中查找所有的Excel文件，找到后写入到工作表的A列单元格中。
        第2行代码声明变量mydir保存返回的文件名称。
        第3行代码声明变量b保存返回的文件数目。
        第4行代码设置变量b的初始值。
        第5行代码清除A列所有数据。
        第6行代码使用Dir函数在代码所在工作簿的文件夹中查找Excel文件。
Dir函数返回一个String，用以表示一个文件名、目录名或文件夹名称，语法如下： Dir[(pathname[, attributes])] 参数pathname是可选的，用来指定文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。
如果没有找到pathname，则会返回零长度字符串 ("")。
        参数attributes是可选的，常数或数值表达式，其总和用来指定文件属性，如表格所示。
如果省略，则会返回不包含属性的匹配文件。
               注意 在第一次调用Dir函数时，必须指定pathname，否则会产生错误。
        第7行到第11行代码将返回的文件名称写入到A列单元格中。
Dir函数会返回匹配 pathname参数的第一个文件名，若想得到其他匹配pathname参数的文件名，需再一次调用Dir函数，且不要使用参数。
如果已没有合乎条件的文件，则Dir函数会返回一个零长度字符串 ("")。
        运行Mydir过程工作表中如图所示。
       
第10部分 文件操作
技巧174 获得当前文件夹的名称 在处理文件时经常需要获得当前文件夹的名称，此时可以使用CurDir函数，如下面的代码所示。

  Sub CurFolder()
      MsgBox CurDir("F")
  End Sub
       CurDir函数返回一个Variant类型的文件路径。
如果需要返回字符串类型的文件路径则使用CurDir$，语法如下： CurDir[(drive)] 参数drive是可选的，字符串表达式，指定一个存在的驱动器。
如果没有指定驱动器，或参数drive 是零长度字符串 ("")，则CurDir函数会返回当前驱动器的路径。
       
第10部分 文件操作
技巧175 创建和删除文件夹 可以在程序运行时创建和删除文件夹，如下面的代码所示。

#MkDir

  Sub TempFolder()
      On Error Resume Next
      MkDir ThisWorkbook.Path & "\Temp"
  End Sub
       TempFolder过程使用MkDir语句在示例所在的文件夹中创建“Temp”文件夹。
MkDir语句创建一个新的目录或文件夹，语法如下： MkDir path 参数path是必需的，指定所要创建的目录或文件夹的字符串表达式，可以包含驱动器。
如果没有指定驱动器，则在当前驱动器上创建新的目录或文件夹。
        第2行代码启动错误处理程序，因为在创建过程中如果文件夹中已存在相同名称的“Temp”文件夹会发生 “路径未找到”错误，所以使用On Error Resume Next语句忽略错误。
        第3行代码使用MkDir语句创建“Temp”文件夹。
        如果需要删除不需要的文件夹可以使用RmDir语句，如下面的代码所示。

#RmDir

  Sub RmFolder()
      On Error Resume Next
      RmDir ThisWorkbook.Path & "\Temp"
  End Sub
       RmFolder过程使用RmDir语句删除在示例所在的文件夹中创建“Temp”文件夹。
RmDir语句删除一个存在的目录或文件夹，语法如下： RmDir path 参数path是必需的，指定所要创建的目录或文件夹的字符串表达式，可以包含驱动器。
如果没有指定驱动器，则在当前驱动器上创建新的目录或文件夹。
        第2行代码启动错误处理程序，因为在使用RmDir语句删除并不存在的文件夹或删除含有文件的文件夹时会发生 “路径未找到”错误，所以使用On Error Resume Next语句忽略错误。
        第3行代码使用RmDir语句删除“Temp”文件夹。
如果“Temp”文件夹中含有文件可以在删除文件夹之前，先使用Kill语句来删除所有文件。

第10部分 文件操作
技巧176 重命名文件或文件夹 Name语句重新命名一个文件、目录、或文件夹，语法如下： Name oldpathname As newpathname 参数oldpathname是必需的，字符串表达式，指定已存在的文件名和位置，可以包含目录或文件夹、以及驱动器。
        参数newpathname是必需的，字符串表达式，指定新的文件名和位置，可以包含目录或文件夹、以及驱动器。
        第2行代码启动错误处理程序，因为在重命名过程中如果参数oldpathname指定的文件或文件夹不存在会发生 “文件未找到”错误，所以使用On Error Resume Next语句忽略错误。

 

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=32
本帖已被收录到知识树中，索引项：开发帮助和教程
我已经把附件发到你邮箱了，
请查收你的邮件。

第10部分 文件操作

技巧177 复制指定的文件

如果需要把文件从一个地方复制到另一个地方，可以使用FileCopy语句复制文件，如下面的代码所示。

#FileCopy

  Sub CopyFile()
      Dim SourceFile As String
      Dim DestinationFile As String
      SourceFile = ThisWorkbook.Path & "\123.xls"
      DestinationFile = ThisWorkbook.Path & "\ABC\abc.xls"
      FileCopy SourceFile, DestinationFile
  End Sub
       FileCopy语句复制一个文件，语法如下： FileCopy source, destination Source参数是必需的，字符串表达式，用来表示要被复制的文件名。
source参数可以包含目录或文件夹、以及驱动器。
        destination参数是必需的，字符串表达式，用来指定要复制的目地文件名。
destination参数 可以包含目录或文件夹、以及驱动器。
        注意 不能对一个已打开的文件使用 FileCopy 语句，否则会产生错误。
        第4行代码指定被复制的文件名称和路径。
        第5行代码指定目的文件名称和路径，如果已存在相同名称的文件则会覆盖原文件。
        第6行代码使用FileCopy语句复制文件。

技巧178 删除指定的文件

使用Kill方法删除指定的文件，如下面的代码所示。

#Kill

  Sub KillFile()
      Dim myFile As String
      myFile = ThisWorkbook.Path & "\123.xls"
      If Dir(myFile) <> "" Then Kill myFile
  End Sub
       第3行代码指定所要删除文件的路径和文件名称。
        第4行代码使用Dir函数返回指定文件名，（关于Dir函数请参阅技巧173 ）如果存在该文件则使用Kill语句删除。
Kill语句从磁盘中删除文件，语法如下：Kill pathname
       在Microsoft Windows中，Kill方法支持多字符 (*) 和单字符(?)的统配符来指定多重文件，如需要删除当前目录下所有*. Xls文件可以使用下面的代码： Kill "*.xls" 注意 使用Kill方法不能删除已打开的文件，否则会产生错误。

技巧179 搜索特定的文件

如果需要对文件夹中所有的Excel文件进行相同的操作，那么可以使用Execute方法进行文件搜索，示例代码如下所示。

#FileSearch

  Sub Sort()
      Dim i As Byte
      Application.ScreenUpdating = False
      With Application.FileSearch
          .LookIn = ThisWorkbook.Path
          .FileType = msoFileTypeExcelWorkbooks
          If .Execute > 0 Then
              For i = 1 To .FoundFiles.Count
                  If .FoundFiles(i) <> ThisWorkbook.FullName Then
                      Workbooks.Open .FoundFiles(i)
                      With ActiveWorkbook
                          .Sheets("Sheet1").Range("A1") = "最后打开时间：" & Now
                          .Close True
                      End With
                  End If
              Next
          End If
      End With
      Application.ScreenUpdating = True  #ScreenUpdating
  End Sub
       Sort过程搜索同一目录中的所有Excel文件并对其进行操作。
        第3行代码关闭屏幕更新功能，加快代码的运行速度。
        第4行代码为文件搜索创建一个FoundFiles对象。
        第5行代码设置要搜索的文件夹，应用于FoundFiles对象的LookIn属性返回或设置在指定的文件搜索过程中要搜索的文件夹。
        第6行代码设置搜索的文件类型为Excel文件，应用于FoundFiles对象的FileType属性返回或设置文件搜索过程中要查找的文件类型，设置为msoFileTypeExcelWorkbooks返回Excel文件。
        第7行代码开始对指定文件进行搜索，应用于FoundFiles对象的Execute方法用于搜索文件，语法如下： expression.Execute(SortBy, SortOrder, AlwaysAccurate) 参数expression是必需的，返回一个FoundFiles对象。
        参数SortBy是可选的，用于对返回的文件进行排序。
        参数SortOrder是可选的，表明所返回文件的排序顺序。
        参数AlwaysAccurate是可选的，设置为True使文件搜索包括上次更新文件索引以来添加、修改或删除的文件。
        在使用Execute方法搜索文件时，如果没有找到文件，则返回零(0)，如果找到一个或多个文件，则返回一个正数。
        第8行代码使用For...Next 语句遍历Execute方法返回的返回的文件列表。
应用于FoundFiles对象的FoundFiles属性返回一个FoundFiles对象，代表由文件搜索过程中返回的文件列表。
        第10行代码使用应用于Workbooks对象的Open方法打开由返回的单个FoundFiles对象代表的工作簿。
        第11行到第14行代码在打开的活动工作簿的工作表中写入打开时间后保存、关闭活动工作簿。
        运行Sort过程将打开示例所在文件夹中所有的Excel文件并对其进行相应的操作。

Option Explicit

Sub test3()
Dim wb As Workbook
Dim i As Long
Dim t
Dim arr()
t = Timer
ActiveSheet.UsedRange = ""
With Application.FileSearch '调用fileserch对象
.NewSearch '开始新的搜索
.LookIn = ThisWorkbook.path '设置搜索的路径
.SearchSubFolders = True '搜索范围包括 LookIn 属性指定的文件夹中的所有子文件夹
.Filename = "*.xl*" '设置搜索的文件类型
If .Execute() > 0 Then '如果找到文件
   ReDim arr(1 To .FoundFiles.Count, 1 To 1)
   For i = 1 To .FoundFiles.Count
      arr(i, 1) = .FoundFiles(i) '把找到的文件放在单元格里
   Next i
Else
   MsgBox "没找到文件"
End If
End With
Range("a1").Resize(i - 1) = arr
MsgBox Timer - t
End Sub

第10部分 文件操作
技巧180 使用WSH处理文件 Windows Scripting Host(WSH)可以创建一些控制Windows操作系统和应用程序以及从操作系统中获取信息的小程序，而使用WSH的FileSystemObject对象可以用来处理文件系统。
        在使用WSH处理文件时，必需使用CreateObject函数创建一个ActiveX对象（FileSystemObject对象），用来提供访问计算机的文件系统，如下面的代码所示：

Dim MyFile As Object

Set MyFile = CreateObject("Scripting.FileSystemObject")
       CreateObject函数创建并返回一个对ActiveX对象的引用，语法如下： CreateObject(class,[servername]) 其中参数class是必需的，要创建的应用程序名称和类，使用appname.objecttype这种语法，appname指定该对象的应用程序名称，objecttype指定该对象的类型或类。
        在声明了对象变量MyFile为Windows Scripting库的FileSystemObject对象后就能使用该对象的属性、方法来处理文件系统。

180-1 获取文件信息

如果需要获得指定文件的信息，可以使用File对象的Getfile方法，如下面的代码所示。

#FileSystemObject

  Sub Fileinfo()
      Dim MyFile As Object
      Dim Str As String
      Dim StrMsg As String
      Str = ThisWorkbook.Path & "\123.xls"
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      With MyFile.Getfile(Str)
          StrMsg = StrMsg & "文件名称：" & .Name & Chr(13) _
              & "文件创建日期：" & .DateCreated & Chr(13) _
              & "文件修改日期：" & .DateLastModified & Chr(13) _
              & "文件访问日期：" & .DateLastAccessed & Chr(13) _
              & "文件保存路径：" & .ParentFolder
      End With
      MsgBox StrMsg
      Set MyFile = Nothing
  End Sub
       Fileinfo过程使用Getfile方法获取示例所在文件夹中的“123.xls”文件的信息。
        第5行代码将文件路径名称赋给变量Str。
        第6行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第7行代码使用Getfile方法返回一个File对象。
Getfile方法返回一个和指定路径中文件相对应的File对象，语法如下：
object.GetFile(filespec) 参数object是必需的，FileSystemObject对象的名称。
        参数filespec是必需的，指定文件的路径。
        第8行到第12行代码根据File对象的属性取得文件信息，File对象的常用属性如表格所示。
               运行Fileinfo过程使用消息框显示“123.xls”文件的信息，如图所示。
       
第10部分 文件操作
技巧180 使用WSH处理文件

180-2 查找文件

使用FileSystemObject对象的FileExists方法可以查找指定的文件，如下面的代码所示。

#FileExists

  Sub FileExis()
      Dim MyFile As Object
      Dim Str As String
      Dim StrMsg As String
      Str = ThisWorkbook.Path & "\123.xls"
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      If MyFile.FileExists(Str) Then
          MsgBox "文件已找到!"
      Else
          MsgBox "文件不存在!"
      End If
      Set MyFile = Nothing
  End Sub
       FileExis过程使用FileExists方法查找示例所在文件夹中是否存在“123.xls”文件。
        第6行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第7行代码使用FileExists方法可以查找文件。
应用于FileSystemObject对象的FileExists方法查找指定的文件，语法如下： object.FileExists(filespec) 参数object是必需的，FileSystemObject对象的名称。
        参数filespec是必需的，要确定是否存在的文件的名字。
如果文件不在当前文件夹中，必须提供一个完整的路径说明。
        使用FileExists方法查找文件时如果指定的文件存在，返回True，若不存在，则返回False，根据返回值可以确定所要查找的文件是否存在。

第10部分 文件操作
技巧180 使用WSH处理文件

180-3 移动文件

如果需要把文件从一个地方移动到另一个地方，可以使用FileSystemObject对象的MoveFile方法，如下面的代码所示。

#MoveFile

  Sub MoveFile()
      Dim MyFile As Object
      On Error Resume Next
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      MyFile.MoveFile ThisWorkbook.Path & "\123.xls", ThisWorkbook.Path & "\ABC"
      Set MyFile = Nothing
  End Sub
       第4行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第5行代码使用MoveFile方法移动文件。
应用于FileSystemObject对象的MoveFile方法将一个或多个文件从一个地方移动到另一个地方，语法如下： object.MoveFile source, destination 参数object是必需的， FileSystemObject对象的名称。
        参数source是必需的，一个或多个要移动文件的路径，source参数字符串在路径的最后部件中可以使用通配符。
        参数destinatio是必需的，一个或多个文件要移动到的目标路径，不能使用通配符。

180-4 复制文件

如果需要把文件从一个地方复制到另一个地方，可以使用CopyFile方法，如下面的代码所示。

#CopyFile

  Sub CopyFile()
      Dim MyFile As Object
      On Error Resume Next
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      MyFile.CopyFile ThisWorkbook.Path & "\123.xls", ThisWorkbook.Path & "\ABC"
      Set MyFile = Nothing
  End Sub
       第4行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第5行代码使用CopyFile方法复制文件。
应用于FileSystemObject对象的CopyFile方法把一个或多个文件从一个地方复制到另一个地方，语法如下： object.CopyFile source, destination[, overwrite] 参数object是必需的， FileSystemObject对象的名字。
        参数source是必需的，指明一个或多个要被复制文件的字符串文件说明，可以包括通配符。
        参数destination是必需的，指明参数source中的一个或多个文件要被复制到的接受端的字符串，不允许有通配符。
        参数overwrite是可选的，表示存在的文件是否被覆盖。
如果是True，文件将被覆盖；如果是False，它们不被覆盖，缺省值是True。
        注意 如果参数destination指定的接受端具有只读属性设置，不论参数overwrite的值如何设置，CopyFile方法都将失败。

180-5 删除文件

如果需要删除一个指定的文件，可以使用DeleteFile方法，如下面的代码所示。

#DeleteFile

  Sub DelFile()
      Dim MyFile As Object
      On Error Resume Next
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      MyFile.DeleteFile ThisWorkbook.Path & "\123.xls"
      Set MyFile = Nothing
  End Sub
       第4行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第5行代码使用DeleteFile方法复制文件。
应用于FileSystemObject对象的DeleteFile方法删除一个指定的文件，语法如下： object.DeleteFile filespec[, force] 参数object是必需的， FileSystemObject对象的名字。
        参数filespec是必需的，指明要删除文件的名字，可以在最后的路径部件中包含通配符。
        参数force是可选的，如果要删除具有只读属性设置的文件，其值为True。
如果其值为False（缺省），则不能删除具有只读属性设置的文件。
。

第10部分 文件操作
技巧180 使用WSH处理文件

180-6 创建文件夹

如果需要创建一个文件夹，可以使用CreateFolder方法，如下面的代码所示。

#CreateFolder

  Sub CreFolder()
      Dim MyFile As Object
      On Error Resume Next
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      MyFile.CreateFolder (ThisWorkbook.Path & "\ABC")
      Set MyFile = Nothing
  End Sub
       第4行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第5行代码使用CreateFolder方法创建文件夹。
应用于FileSystemObject对象的CreateFolder方法创建一个文件夹，语法如下： object.CreateFolder(foldername) 参数object是必需的， FileSystemObject对象的名字。
        参数foldername是必需的，字符串表达式，指明要创建文件夹的名称和路径。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=33
第10部分 文件操作
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧180 使用WSH处理文件

180-7 复制文件夹

如果需要复制文件夹，可以使用CopyFolder方法，如下面的代码所示。

#CopyFolder

  Sub CopyFolder()
      Dim MyFile As Object
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      MyFile.CopyFolder ThisWorkbook.Path & "\ABC", ThisWorkbook.Path & "\123"
      Set MyFile = Nothing
  End Sub
       第4行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第5行代码使用CopyFolder方法复制文件夹。
应用于FileSystemObject对象的CreateObject方法从一个地方递归地复制一个文件夹到另一个地方，语法如下： object.CopyFolder source, destination[, overwrite] 参数object是必需的， FileSystemObject对象的名字。
        参数source是必需的，指明一个或多个被复制文件夹的字符串文件夹说明，可以包括通配符。
        参数destination是必需的，被复制文件夹和子文件夹的接受端的字符串，不允许有通配符。
        参数overwrite是可选的，表示已存在的文件夹是否被覆盖。
如果为True，文件被覆盖，如果为False，文件不被覆盖。
缺省值为True。
        如果参数source中包含通配符或参数destination以路径分隔符（\）为结尾，则认为参数destination是一个已存在的文件夹，在其中复制相匹配的文件夹和子文件夹。
否则认为参数destination是一个要创建的文件夹的名字。

第10部分 文件操作
技巧180 使用WSH处理文件

180-8 移动文件夹

如果需要移动文件夹，可以使用MoveFolder方法，如下面的代码所示。

#MoveFolder

  Sub MoveFolder()
      Dim MyFile As Object
      On Error Resume Next
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      MyFile.MoveFolder ThisWorkbook.Path & "\123", "F:\123"
      Set MyFile = Nothing
  End Sub
       第4行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第5行代码使MoveFolder方法移动文件夹。
应用于FileSystemObject对象的MoveFolder方法将一个或多个文件夹从一个地方移动到另一个地方，语法如下： object.MoveFolder source, destination 参数object是必需的， FileSystemObject对象的名字。
        参数source是必需的，指明一个或多个要移动文件夹的字符串文件夹说明，在路径的最后部件中可以包括通配符。
        参数destination是必需的，一个或多个文件夹要移动到的目标路径，不能包含通配符。
        如果参数source中包含通配符或参数destination以路径分隔符（\）为结尾，则认为参数destination是一个已存在的文件夹，在此文件夹中移动相匹配的文件。
否则认为参数destination是一个要创建的文件夹的名字。

第10部分 文件操作
技巧180 使用WSH处理文件

180-9 删除文件夹

如果需要删除一个文件夹，可以使用DeleteFolder方法，如下面的代码所示。

#DeleteFolder

  Sub DelFolder()
      Dim MyFile As Object
      On Error Resume Next
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      MyFile.DeleteFolder ThisWorkbook.Path & "\123"
      Set MyFile = Nothing
  End Sub
       第4行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile。
        第5行代码使用DeleteFolder方法删除文件。
应用于FileSystemObject对象的DeleteFolder方法删除一个指定的文件夹和其中的内容，语法如下： object.DeleteFolder folderspec[, force] 参数object是必需的， FileSystemObject对象的名字。
        参数filespec是必需的，指明要删除的文件夹的名称，可以在最后的路径部件中包含通配符。
        参数force是可选的，如果要删除具有只读属性设置的文件夹，其值为True。
如果其值为False（缺省），则不能删除具有只读属性设置的文件夹。

第10部分 文件操作
技巧180 使用WSH处理文件

180-10 导入文本文件

如果需要从文本文件中导入数据，可以使用OpenTextFile方法，如下面的代码所示。

#OpenTextFile

  Sub OpenText()
      Dim MyFile As Object
      Dim mArr() As String
      Dim j As Integer, i As Integer
      j = 1
      Sheet1.UsedRange.ClearContents
      Set MyFile = CreateObject("Scripting.FileSystemObject") _
          .OpenTextFile(ThisWorkbook.Path & "" & "工资表.txt")
      Do While Not MyFile.AtEndOfStream
          mArr = Split(MyFile.ReadLine, ",")
          For i = 0 To UBound(mArr)
              Sheet1.Cells(j, i + 1) = mArr(i)
          Next
          j = j + 1
      Loop
      MyFile.Close
      Set MyFile = Nothing
  End Sub
       第7、8行代码使用OpenTextFile方法打开文本文件。
应用于FileSystemObject对象的OpenTextFile方法打开一个指定的文件并返回一个TextStream对象，该对象可用于对文件进行读操作或追加操作，语法如下： object.OpenTextFile(filename[, iomode[, create[, format]]]) 参数object是必需的，FileSystemObject对象的名字。
        参数filename是必需的，需要打开的文件名称。
        参数iomode是可选的，表示输入/输出方式，设置值如表格所示。
               参数create是可选的，它表示如果指定的参数filename不存在是否可以创建一个新文件。
如果创建新文件，其值为True。
若不创建文件其值为False。
缺省值为False。
        参数format是可选的，打开文件的格式，设置值如表格所示。
               第9行代码开始对文本文件进行读操作。
应用于TextStream对象的AtEndOfStream属性指示文件指针是否位于TextStream文件中的结尾，如果是返回True，否则返回False。
        第10行代码使用Split函数将逐行读取的字符串以逗号进行分隔后赋给数组mArr。
关于Split函数请参阅技巧169-2。
        应用于TextStream对象的ReadLine方法从一个TextStream文件读取一整行（到换行符但不包括换行符）并返回得到的字符串，语法如下： object.ReadLine 参数object是必需的，TextStream对象的名字。
        第11行到第14行代码将数组元素写入到工作表的单元格。
        第15行代码重新读取下一行数据。
        第16行使用Close方法关闭打开的文本文件。
        运行OpenText过程将“工资表.txt”文件的数据导入到工作表中。

180-11 创建文本文件

如果需要将工作表中的数据保存为文本文件，可以创建一个文本文件用于保存数据。
        使用CreateTextFile方法创建文本文件，如下面的代码所示。

#CreateTextFile

  Sub CreText()
      Dim MyFile As Object
      Dim myStr As String
      Dim j As Integer, i As Integer
      Set MyFile = CreateObject("Scripting.FileSystemObject") _
          .CreateTextFile(ThisWorkbook.Path & "" & "工资表.txt", True)
          For i = 1 To Range("A65536").End(xlUp).Row
              myStr = ""
              For j = 1 To Range("IV"& i).End(xlToLeft).Column
                  myStr = myStr & Cells(i, j) & ","
              Next
              myStr = Left(myStr, (Len(myStr) - 1))
              MyFile.WriteLine (myStr)
          Next
      MyFile.Close
      Set MyFile = Nothing
  End Sub
       CreText过程使CreateTextFile方法创建一个指定名称的文本文件并将工作表数据写入到文件内。
        第5、6行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile后使用CreateTextFile方法创建一个指定名称的文本文件。
        应用于FileSystemObject对象的CreateTextFile方法创建一个指定的文件并且返回一个用于该文件读写的TextStream对象，语法如下： object.CreateTextFile(filename[, overwrite[, unicode]]) 参数object是必需的，FileSystemObject对象的名字。
        参数filename是必需的，需要创建的文件名称。
        参数overwrite是可选的，表示是否覆盖已存在文件。
如果可被覆盖其值为True，其值为False时不能覆盖，如果省略，则已存在文件不能覆盖。
       参数unicode是可选的，表示文件是作为一个Unicode文件创建的还是作为一个ASCII文件创建的。
如果作为一个Unicode文件创建，其值为True，作为一个ASCII 文件创建，其值为False，如果省略，则认为是一个ASCII文件。
        第7行代码逐行读取工作表数据。
       第8行代码清空字符串变量myStr的内容，用来保存下一行的数据。
       第9行代码遍历当前行的所有单元格。
        第10行代码将当前行的所有单元格保存到字符串变量myStr中并以逗号进行分隔。
        第12行代码去除保存在字符串变量myStr中当前行数据的最后一个逗号。
        第13行代码使用WriteLine方法将当前行数据写入到创建的文本文件。
        应用于TextStream对象的WriteLine方法写入一个指定的字符串和换行符到一个TextStream文件中，语法如下： object.WriteLine([string]) 参数object是必需的，TextStream对象的名字。
        参数string是可选的，要写入文件的正文。
如果省略，写入一个换行符。
        第15行使用Close方法关闭打开的文本文件。
        还可以使用OpenTextFile方法创建文本文件，如下面的代码所示。

  Sub OpenText()
      Dim MyFile As Object
      Dim myStr As String
      Dim j As Integer, i As Integer
      Set MyFile = CreateObject("Scripting.FileSystemObject") _
          .OpenTextFile(ThisWorkbook.Path & "" & "工资表.txt", 8, True)
          For i = 1 To Range("A65536").End(xlUp).Row
              myStr = ""
              For j = 1 To Range("IV" & i).End(xlToLeft).Column
                  myStr = myStr & Cells(i, j) & ","
              Next
              myStr = Left(myStr, (Len(myStr) - 1))
              MyFile.WriteLine (myStr)
          Next
      MyFile.Close
      Set MyFile = Nothing
  End Sub
       OpenText过程使OpenTextFile方法创建一个指定名称的文本文件并将工作表数据写入到文件内。
        应用于FileSystemObject对象的OpenTextFile方法打开一个指定的文件并返回一个 TextStream对象，该对象可用于对文件进行读操作或追加操作，请参阅技巧180-10。
        示例中将OpenTextFile方法的iomode参数设置为8，打开文本文件后在文件的尾部进行追加操作；将create参数设置为True，如果指定的文本文件不存在则创建一个新文件。
       注意 如果重复运行OpenText过程将在文本文件中重复写入工作表数据，所以OpenTextFile方法更适用于对文本文件进行追加操作。
        OpenText过程的其他代码请参阅CreText过程的代码解析。
        运行CreText过程和OpenText过程将在示例所在的文件夹中创建一个名称为：“工资表”的文本文件并将工作表数据读入到文件内。

 

技巧181 取得电脑名称

如果希望使用VBA开发的程序只能在某一特定的电脑中使用，那么可以在程序开始时检查当前电脑的名称是否是指定的名称，如下面的代码所示。

  Private Sub Workbook_Open()
      Dim myName As String
      myName = Environ("Computername")
      If myName <> "ERPSERVER" Then
          MsgBox "对不起您不是合法用户，文件将关闭!"
          ThisWorkbook.Close
      End If
  End Sub
       工作簿的Open事件过程，在工作簿打开时判断电脑的名称，如果不是“ERPSERVER”则退出关闭工作簿。
        第3行代码取得电脑的名称。
Environ函数返回String，关连一个操作系统环境变量，语法如下： Environ({envstring | number}) 参数envstring是可选的，包含一个环境变量名的字符串表达式。
如果在环境字符串表格中找到参数envstring，则Environ函数返回在环境字符串表格中对应那个环境变量的等号后面的那段文本。
        Environ("Computername")返回电脑名称，如果需要取得当前登录用户的用户名则使用Environ("UserName")。
        参数number是可选的，用来表示环境字符串在环境字符串表格中的数值顺序。
number 参数可以是任意的数值表达式，不过在计算前，它会先转换为一个整数。
        第4行到第7行代码，如果当前电脑不是指定的电脑，关闭工作簿。
在实际应用中需要配合其他方法使用户在打开时强制启用宏才能达到这一效果。

第11部分 其他应用
技巧182 取得逻辑盘序列号 在技巧181 中使用Environ函数返回电脑的名称，使程序只能在某一特定的电脑中使用。
但是电脑名称并不是唯一的，有可能多台电脑使用同一名称，所以更好的方法是程序开始时检查电脑的逻辑盘序列号是否是指定的序列号。
取得逻辑盘序列号可以使用下面的代码。

  Sub DriveID()
      Dim DriveID
      Set DriveID = CreateObject("Scripting.FileSystemObject")
      MsgBox "C盘的序列号是：" & DriveID.GetDrive("C").SerialNumber, 64
  End Sub
       DriveID过程使用GetDrive方法取得电脑C盘的序列号。
        应用于FileSystemObject对象的GetDrive方法返回一个与指定路径中的驱动器相对应的Drive对象，语法如下： object.GetDrive drivespec object参数是必需的， FileSystemObject对象的名字。
关于FileSystemObject对象的引用请参阅技巧180 。
        Drivespec参数是必需的，可以是一个驱动器字符（c）、一个驱动器字符加一个冒号（c:）、一个驱动器字符加冒号和路径分隔符（c:\）或任何网络共享的说明（\\computer2\share1）。
        在使用GetDrive方法返回一个Drive对象后，就可以使用其SerialNumber属性返回C盘的序列号。
Drive对象对特定磁盘驱动器或网络共享的属性提供访问，而应用于Drive对象的SerialNumber属性用于唯一标识磁盘卷标的十进制序列号，语法如下： object.SerialNumber 运行DriveID过程将使用消息框显示电脑C盘的序列号，如图所示。

技巧183 使用API取得硬盘信息 在VBA中可以使用API函数取得逻辑盘序列号和唯一的物理系列号，如下面的代码所示。

  Private Const MAX_IDE_DRIVES As Long = 4
  Private Const READ_ATTRIBUTE_BUFFER_SIZE As Long = 512
  Private Const IDENTIFY_BUFFER_SIZE As Long = 512
  Private Const READ_THRESHOLD_BUFFER_SIZE As Long = 512
  Private Const DFP_GET_VERSION As Long = &H74080
  Private Const DFP_SEND_DRIVE_COMMAND As Long = &H7C084
  Private Const DFP_RECEIVE_DRIVE_DATA As Long = &H7C088
  ……代码略，详见附件
  '取得硬盘信息：型号/物理系列号（唯一）
  Function GetHardDiskInfo(Optional ByVal numDisk As eumDiskNo = hdPrimaryMaster, Optional ByVal numType As eumInfoType = hdOnlySN) As String
      If GetDiskInfo(numDisk) = 1 Then
          Dim pSerialNumber As String, pModelNumber As String
          pSerialNumber = StrConv(m_DiskInfo.sSerialNumber, vbUnicode)
          pModelNumber = StrConv(m_DiskInfo.sModelNumber, vbUnicode)
          Select Case numType
              Case hdOnlyModel '仅型号
                  GetHardDiskInfo = Trim(pModelNumber)
              Case hdOnlySN '仅系列号
                  GetHardDiskInfo = Trim(pSerialNumber)
              Case Else '型号,系列号
                  GetHardDiskInfo = Trim(pModelNumber) & "," & Trim(pSerialNumber)
          End Select
       End If
  End Function
       使用API函数取得逻辑盘序列号和唯一的硬盘物理系列号，其中GetDiskVolume函数过程取得逻辑盘序列号，GetHardDiskInfo函数过程取得唯一的硬盘物理系列号。
        调用此函数的代码如下。

  Sub DiskId()
      MsgBox "硬盘的物理系列号：" & GetHardDiskInfo(hdPrimaryMaster, hdOnlySN) _
          & Chr(13) & "C盘的序列号：" & GetDiskVolume("C")
  End Sub
      
第11部分 其他应用
技巧184 使用数字签名 对于Excel中包含VBA的文档，用户最恐惧的一件事情便是是否有病毒，因此往往把Excel安全级别设置为“中”，即对不可靠的来源提醒用户是否启用宏。
而对于VBA开发人员来说，最想做的就是使Excel程序启动时不出现警告对话框，直接进入（在安全级别为中的情况下），这时就可以使用数字签名。
        数字签名仅在安装了Microsoft Internet Explorer 4.0 或其后续版本的计算机上有效，并且在安装Excel时，需要选择数字签名一项。
        从“开始”→“程序”→“Microsoft Office” →“Microsoft Office工具” →“VBA项目的数字证书”，在打开的窗口中输入的名称，这时已经完成数字证书的制作，如图所示。

       在Office的安装目录下双击文件“Selfcert.exe”，也可以制作数字证书。
        当程序开发完成后，在VBE窗口中选择“工具”→“数字签名”，在如图所示的对话框中选择“选择”按钮。

       在显示的如图所示的对话框中选择新建的数字证书后按“确定”按钮后保存文件。

       第一次打开含有数字签名的文件时，会显示如图所示的“安全警告”对话框。
此时只需要选择“总是相信来自此发布者的宏”选项，这样只要是用此证书签名的文档都会被认为是可靠来源，以后不会再出现“安全警告”对话框。

       如果在打开别人签名的文件时“总是相信来自此发布者的宏”选项为灰，只需选择“详细信息”，在显示的“数字签名详细信息”对话框的“常规”选项中选择“查看证书”，如图 184 5所示。

       然后在显示的“证书”对话框中选择“安装证书”即可，如图所示。

       如果需要删除数字证书，可以打开IE属性对话框，在“内容”选项中选择“证书”，在显示的“证书”对话框中选择证书后删除，如图所示。

       如果有些数字证书在IE属性对话框看不到，可以点击Windows的开始菜单，点击“运行”，键入“Regedit”，回车便打开了注册表编辑器。
在“HKEY_CURRENT_USER\Software\Microsoft\SystemCertificates\”位置选择相应的选项删除即可，如图所示。

第11部分 其他应用
技巧185 暂停代码的运行

在程序运行过程中，如果需要暂时停止宏代码的执行，可以使用Wait方法，如下面的代码所示。

#Wait

  Private Sub UserForm_Activate()
      Dim i As Integer
      For i = 1 To 10
          Label1.Caption = "这是个演示窗体,将在" & 11 - i & "秒后自动关闭!"
          Application.Wait Now() + VBA.TimeValue("00:00:01")
          DoEvents
      Next
      Unload Me
  End Sub
       窗体的激活事件，使用Wait方法使窗体显示10秒后关闭。
        第4行代码在窗体的标签中显示倒计时关闭的秒数。
        第5行代码使用Wait方法使代码暂停运行1秒钟。
应用于Application对象的Wait方法暂停运行宏，直到一特定时间才继续运行宏，语法如下： Wait(Time) 参数Time是必需的，指定想要重新继续执行宏的时间点，以Microsoft Excel日期格式表示。
        使用该方法将暂停Microsoft Excel的所有操作，但不影响后台操作，例如打印和重新计算。
        第6行代码使用DoEvents函数转让控制权，更新标签中倒计时秒数。
        运行窗体，标签中显示倒计时关闭的秒数并在10秒后关闭，如图所示。
               使用Wait方法只能提供精度为1秒的延时，如果需要更低精度的延时，需要使用Sleep API函数，如下面的代码所示。

  Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  Sub TypeDemo()
      Dim sTest As String
      Dim i As Integer
      sTest = "这是Sleep API函数的一个简单演示。
"
      For i = 1 To Len(sTest)
          Range("A1").Value = Left(sTest, i)
          Sleep 200
      Next
  End Sub
       TypeDemo过程模拟打字效果在单元格A1中输入一行文字。
        第1行代码Sleep API函数声明，参数dwMilliseconds为以毫秒为单位的时间长度。
        在第6行到第9行代码在每次循环时增加显示的数据，并且在每次增加时使用Sleep语句延时200毫秒，好像字符逐个输入，从而达到模拟打字的效果。

第11部分 其他应用

技巧186 定时关机

在VBA中可以使用Shell函数执行Shutdown.exe程序实现定时关闭电脑，如下面的代码所示。

#Shutdown
Sub Shutdown() Shell ("at 08:31 Shutdown.exe -s") End Sub
       Shutdown过程使用Shell函数在08:31时自动关闭电脑。
Shell函数执行一个可执行文件，语法如下： Shell(pathname[,windowstyle]) 参数pathname是必需的，要执行的程序名，以及任何必需的参数或命令行变量，可能还包括目录或文件夹，以及驱动器。
在Macintosh中，可以使用MacID函数来指定一个应用程序的署名而不是名称。
表格中列出了执行windows中常用程序的代码。
               参数windowstyle是可选的，表示在程序运行时窗口的样式。
如果省略，则程序是以具有焦点的最小化窗口来执行的。
windowstyle参数的值如表格所示。
       
第11部分 其他应用

技巧187 打开指定的网页

使用VBA可以打开指定的网页，如下面的代码所示。

#FollowHyperlink 

  Sub Hyperlink()
      ActiveWorkbook.FollowHyperlink _
          Address:="http://club.excelhome.net/dispbbs.asp", _
          NewWindow:=True
  End Sub
       Hyperlink过程使用FollowHyperlink方法打开Excel Home论坛的主页。
        FollowHyperlink方法对指定超链接进行处理以下载目标文档，然后将该文档在适当的应用程序中显示出来，语法如下：
expression.FollowHyperlink(Address, SubAddress, NewWindow, AddHistory, ExtraInfo, Method, HeaderInfo) 其中参数expression是必需的，返回一个Workbook对象。
        参数Address是必需的，String类型，目标文档的地址。
        参数SubAddress是可选的，目标文档中的位置，默认值为空字符串。
        参数NewWindow是可选的，Variant类型，如果该值为True，则将目标应用程序显示到一个新窗口中。
默认值为False。
        运行Hyperlink过程将打开Excel Home论坛的主页。

第11部分 其他应用
技巧188 VBE的操作

188-1 添加模块和过程

在工作簿中添加新的模块和过程，除了使用手工添加的方法外，还可以采用程序的方式自动添加，如下面的代码所示。

  Sub NowModule()
      Dim VBC As VBComponent
      Set VBC = ThisWorkbook.VBProject.VBComponents _
          .Add(vbext_ct_StdModule)
      VBC.Name = "NowModule"
      With VBC.CodeModule
          If .Lines(1, 1) <> "Option Explicit" Then
              .InsertLines 1, "Option Explicit"
          End If
          .InsertLines 2, "Sub Process1()"
          .InsertLines 3, vbTab & "MsgBox ""这是第一个过程!"""
          .InsertLines 4, "End Sub"
          .AddFromString "Sub Process2()" & Chr(13) & vbTab _
              & "MsgBox ""这是第二个过程!""" & Chr(13) & "End Sub"
      End With
      Set VBC = Nothing
  End Sub
       NowModule过程在VBE中添加一个“NowModule”模块和两个过程。
        第2行代码声明变量VBC为VBComponent对象。
VBComponent对象代表一个包含在工程中的部件，例如类模块或标准模块。
        第3、4行代码使用Add方法添加一个模块。
应用于VBComponents集合的Add方法将一个对象添加到集合，语法如下： object.Add(component) 参数object是必需的，一个有效的对象表达式。
        参数component是必需的，对于VBComponents集合，则为表示类模块、窗体、标准模块的列举常数，如表格 所示。
               第5行代码将新添加的模块重命名为“NowModule”。
        第7行到第12行代码使用InsertLines方法在新添加的模块中插入过程“Process1”。
应用于CodeModule对象的InsertLines方法在一个代码块的某个指定位置，插入一行或多行的代码，语法如下： object.InsertLines(line, code) 参数object是必需的，一个有效的对象表达式。
        参数line是必需的，Long型数据，用来指定要插入代码的位置。
        参数code是必需的，String型数据，插入的代码。
        其中第7行到第9行代码判断模块中首行代码是否为要求变量声明，如不是则添加要求变量声明语句。
        第13、14行代码使用AddFromString方法在新添加的模块中插入过程“Process2”。
应用于CodeModule对象的AddFromString方法将文本添加到模块，与InsertLines方法不同的是，所插入文本的位置始终在模块中的第一个过程之前，如果模块中没有包含过程则将插入的文本放置在模块的最后。
        运行NowModule过程，在VBE中添加一个“NowModule”模块以及在模块中添加两个过程，如图所示。

 

第11部分 其他应用
技巧188 VBE的操作

188-2 建立事件过程

在使用VBA代码添加工作表后，如果需要在新工作表中添加事件过程，可以使用技巧188-1中的添加代码的方法，但是事件过程一般包含参数，因此此方法容易出错，所以更好的方法是使用CreateEventProc方法，如下面的代码所示。

  Sub AddMatter()
      Dim Sh As Worksheet
      Dim i As Integer
      For Each Sh In Worksheets
          If Sh.Name = "abc" Then
              MsgBox "工作簿中已有""abc""工作表,不能重复添加!"
              Exit Sub
          End If
      Next
      Set Sh = Sheets.Add(After:=Sheets(Sheets.Count))
      Sh.Name = "abc"
      Application.VBE.MainWindow.Visible = True
      With ThisWorkbook.VBProject.VBComponents(Sh.CodeName).CodeModule
          i = .CreateEventProc("SelectionChange", "Worksheet")
          .ReplaceLine i + 1, vbTab _
              & "MsgBox ""你选择了"" & Target.Address(0, 0) & ""单元格!"""
      End With
      Application.VBE.MainWindow.Visible = False
      Set Sh = Nothing
  End Sub
       AddMatter过程在工作簿中新建一张“abc”工作表，并在工作表的SelectionChange事件中写入事件代码。
        第4行到第11行代码使用Add方法在工作簿中新建一张工作表，请参阅技巧25 。
        第12行代码打开VBE窗口。
        第14行代码使用CreateEventProc方法在新添加的工作表中创建“SelectionChange”过程并将起始行号赋给变量i。
        应用于CodeModule对象的CreateEventProc方法创建一个事件过程，语法如下： object.CreateEventProc(eventname, objectname) As Long 参数object是必需的，一个有效的对象表达式。
        参数eventname是必需的，用来指定欲添加到模块的事件名称。
        参数objectname是必需的，用来指定事件源的对象名称。
        CreateEventProc方法创建成功则返回事件过程开始行的行号，其创建的过程只包含一个空行。
        第15、16行代码使用ReplaceLine方法将空行替换为指定的代码。
应用于CodeModule对象的ReplaceLine方法用特定的代码代替原代码，语法如下： object.ReplaceLine(line, code) 参数object是必需的，一个有效的对象表达式。
        参数line是必需的，用来指定所要代替的行号。
        参数code是必需的，用来指定要插入的代码。
        第18行代码关闭VBE窗口。
        运行AddMatter过程在工作簿中新建一张“abc”工作表，并在工作表中写入事件代码，如图所示。
       

第11部分 其他应用
技巧188 VBE的操作

188-3 模块的导入与导出

在使用InsertLines方法和CreateEventProc方法在模块中插入代码，如果插入的代码量较大时，编写的代码会比较长，此时更好的方法是将代码直接导入到模块中，如下面的代码所示。

  Sub CopyModule()
      Dim Nowbook As Workbook
      ThisWorkbook.VBProject.VBComponents("AddMatter").Export ThisWorkbook.Path & "\Tese.txt"
      Set Nowbook = Workbooks.Add
      With Nowbook
          .SaveAs Filename:=ThisWorkbook.Path & "" & "CopyModule.xls"
          .VBProject.VBComponents.Import ThisWorkbook.Path & "\CopyModule.txt"
          .Close Savechanges:=True
      End With
      Kill ThisWorkbook.Path & "\Tese.txt"
  End Sub
       CopyModule过程将示例工作簿中的“AddMatter”模块导入到新建的工作簿“CopyModule.xls”中。
        第3行代码使用Export方法将“AddMatter”模块导出为文本文件。
应用于VBComponent 对象的Export方法将部件按文件进行保存，语法如下： object.Export(filename) 参数object是必需的，一个有效的对象表达式。
        参数filename是必需的，用来指定部件输出为文件的文件名称。
        第4行代码使用Add方法创建一个工作簿。
关于Add方法请参阅技巧41 。
        第7行代码使用Import方法给新工作簿的VBA工程添加部件。
Import方法从文件给工程添加部件，返回该被添加的新部件，语法如下： object.Import(filename) As VBComponent 参数object是必需的，一个有效的对象表达式。
        参数filename是必需的，用来指定欲添加部件的路径及文件名称。
        第8行代码使用Close方法保存新建工作簿后关闭该工作簿。
关于Close方法请参阅技巧48 。
        第10行代码使用Kill方法删除导出的文本文件。
关于Kill方法请参阅技巧178 。
        运行CopyModule过程将创建新工作簿并把示例工作簿中的“AddMatter”模块导入到新工作簿中。

第11部分 其他应用
技巧188 VBE的操作

188-4 删除宏代码

在将一个含有宏代码的工作簿拷贝给用户使用时，如果用户并不需要其中的宏代码，可以使用代码删除其中部分或全部的宏代码后再拷贝给用户使用，如下面的代码所示。

  Sub DelMacro()
      Dim Wb As Workbook
      Dim FileName As String
      Dim Vbc As VBComponent
      FileName = ThisWorkbook.Path & "\DelMacro.xls"
      Application.EnableEvents = False
      Set Wb = Workbooks.Open(FileName)
      For Each Vbc In Wb.VBProject.VBComponents
          If Vbc.Type <> vbext_ct_Document Then
              If Vbc.Name = "NowModule" Then
                  Vbc.CodeModule.DeleteLines 3, Vbc.CodeModule.CountOfLines - 4
              Else
                  Wb.VBProject.VBComponents.Remove Vbc
              End If
          End If
      Next
      'Wb.Close True
      Application.EnableEvents = True
  End Sub
       DelMacro过程删除“DelMacro.xls”工作簿中的部分宏代码。
        第5行代码指定需要删除宏代码的工作簿。
        第6行代码打开工作簿时禁止触发事件。
        第7行代码使用Open方法打开指定工作簿。
关于Open方法请参阅技巧42 。
        第8行代码遍历指定工作簿中所有的VBA部件。
        第9行代码保留Excel对象事件的代码。
应用于VBComponent对象的Type属性返回对象的类型，常用的Type属性值如表格所示。
               第10、11行代码，如果模块名称是“NowModule”则删除其中指定行数代码。
应用于CodeModule对象的DeleteLines方法删除一个单行或指定行范围的代码，语法如下： object.DeleteLines (startline) [count] 参数object是必需的，一个有效的对象表达式。
        参数startline是必需的，用来指定删除的开始行。
        参数count是可选的，用来指定删除的行数。
如果没有指定count参数，则只删除一行代码。
        而应用于CodeModule对象的CountOfLines属性返回代码模块中的总行数。
       第13行代码，如果不是需保留的项目全部则删除。
应用于VBComponents集合的Remove方法从集合中删除项目，语法如下： object.Remove(component) 参数object是必需的，一个有效的对象表达式。
        参数component是必需的，对于VBComponents集合，代表一个类模块、一个窗体，或者是一个标准模块。
        在示例所在文件夹中的“DelMacro.xls”工作簿的VBA项目中有两个模块、一个用户窗体及一个BeforeClose事件过程，运行DelMacro过程，只保留其中的BeforeClose事件过程和“NowModule”模块中的部分代码，其他的全部删除。
        为了演示方便在“DelMacro.xls”工作簿的BeforeClose事件过程中将Saved属性设置为True使其关闭时不保存修改。
在实际应用中应该在DelMacro过程的最后添加一行保存后关闭“DelMacro.xls”工作簿的代码： Wb.Close True 使用Close方法关闭“DelMacro.xls”工作簿，请参阅技巧45 。

 

第11部分 其他应用
技巧189 保护VBA代码 VBA项目的源代码是完全开放的，如果不希望其他人看到源代码，可以使用以下两种方法将代码保护起来。

189-1 设置工程密码

设置VBA工程的密码，只有在输入正确密码后才能看到源代码。
        在VBE窗口中单击菜单“工具”→“VBAProject属性”，在显示的“VBAProject—工程属性”对话框的“保护”选项卡中选中“查看时锁定工程”复选框，并在“密码”文本框和“确认密码”文本框中输入密码后单击“确定”按钮关闭该对话框，保存并关闭文件。
               密码保护完成后，当试图打开该工程时会显示“VBAProject密码”的对话框，只有在输入正确的密码后才能看到该工程的源代码。
        

189-2 设置

“工程不可查看” 使用“保护并共享工作簿”功能将工程设置为不可查看。
        在Excel中选择菜单“工具”→“保护”→“保护并共享工作簿”，在显示的“保护并共享工作簿”对话框中选中“以追踪修订方式共享”复选框，激活对话框中灰色的输入密码区域，在“密码”文本框中输入密码后单击“确定”按钮。
               在显示的“确认密码”对话框中再次输入密码后单击“确定”按钮。
               此时系统会显示“此操作将导致保存文档。
是否继续？”的对话框。
               单击“确定”按钮后在显示的对话框中单击“确定”按钮即可。
               完成设置后当在VBE中查看工程时则会出现一个“工程锁定”的对话框，提示“工程不可查看”。
               如果需要取消“工程不可查看”只需在Excel中选择菜单“工具”→“保护”→“撤消对共享工作簿的保护”在显示的“取消共享保护”对话框中需要输入正确的密码中单击“确定”按钮即可。
        https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=35
第11部分 其他应用
本帖已被收录到知识树中，索引项：开发帮助和教程
技巧190 优化代码

190-1 关闭屏幕刷新

在使用代码改变工作表的显示内容或格式时关闭屏幕刷新可以加快运行速度，如下面的代码所示。

  Sub Screen()
      Dim i As Integer
      Dim t As Date
      Dim t1 As String
      Dim t2 As String
      Application.ScreenUpdating = False
      t = Timer
      For i = 1 To 30000
          Cells(1, 1) = i
      Next
      t1 = Timer - t
      Application.ScreenUpdating = True
      t = Timer
      For i = 1 To 30000
          Cells(1, 1) = i
      Next
      t2 = Timer - t
      MsgBox "关闭屏幕刷新运行时间:" & Format(t1, "0.00000") & "秒" _
           & Chr(13) & "开启屏幕刷新运行时间:" & Format(t2, "0.00000") & "秒"
  End Sub
       Screen过程使用两次For...Next语句给A1单元格填充数据，最后使用消息框显示两次运行的时间。
在第一次循环时关闭屏幕刷新，应用于Application对象的ScreenUpdating属性设置屏幕刷新功能是否打开，设置为False关闭屏幕刷新，将看不到代码的执行过程，但可以加快代码的运行速度。
        运行Screen过程，消息框显示两次代码的运行时间，可以看出关闭屏幕刷新后运行时间远远小于开启屏幕刷新时运行的时间，如图所示。
       
第11部分 其他应用
技巧190 优化代码

190-2 使用工作表函数

在VBA中使用工作表函数比仅仅使用VBA代码的运行时间要快得多，如下面的代码所示。

#WorksheetFunction

  Sub ShFunction()
      Dim i As Integer
      Dim t As Date
      Dim t1 As String
      Dim t2 As String
      Range("B1:B2").ClearContents
      Application.ScreenUpdating = False
      t = Timer
      For i = 1 To 30000
          Cells(1, 2) = Cells(1, 2) + Cells(i, 1)
      Next
      t1 = Timer - t
      t = Timer
      Cells(2, 2) = Application.WorksheetFunction.Sum(Range("A1:A30000"))
      t2 = Timer - t
      Application.ScreenUpdating = True
      MsgBox "第一次运行时间:" & Format(t1, "0.00000") & "秒" _
           & Chr(13) & "第二次运行时间:" & Format(t2, "0.00000") & "秒"
  End Sub
       ShFunction过程分别使用VBA代码和调用工作表Sum函数对单元格区域进行求和计算，最后使用消息显示运行时间。
        第9行到第11行代码使用VBA的累加方法计算单元格A1：A30000的和。
        第14行代码调用工作表Sum函数计算单元格A1：A30000的和。
VBA中调用工作表函数请参阅技巧153 。
        运行ShFunction过程，消息框显示两种方法的运行时间，可以看出调用工作表函数进行计算的运行时间要远远小于使用累加方法运行的时间，如图所示。
       
第11部分 其他应用
技巧190 优化代码

190-3 使用更快的单元格操作方法

在对单元格区域进行操作时，使用Find、Replace、SpecialCells等方法可以比使用VBA代码获得更快的速度，如下面的代码所示。

  Sub Methods()
      Dim arr As Variant
      Dim i As Long
      Dim t As Date
      Dim t1 As String
      Dim t2 As String
      With Range("A1:A20000")
          arr = .Value
          t = Timer
          For i = 20000 To 1 Step -1
              If Cells(i, 1) = "Excel" Then
                  Cells(i, 1).EntireRow.Delete
              End If
          Next
          t1 = Timer - t
          .Value = arr
          t = Timer
          .Replace "Excel", ""
          .SpecialCells(4).EntireRow.Delete
      End With
      t2 = Timer - t
      MsgBox "第一次运行时间:" & Format(t1, "0.00000") & "秒" _
           & Chr(13) & "第二次运行时间:" & Format(t2, "0.00000") & "秒"
  End Sub
       第8行代码将单元格数据保存在数组arr中，因为在运行第2种方法前需要恢复单元格数据。
        第10行到第14行代码，采用遍历单元格的方法删除内容为“Excel”的单元格所在的行。
        第16行代码恢复单元格原有的数据。
        第18行代码使用Replace方法将内容为“Excel”的单元格替换成空白单元格。
        第19行代码使用SpecialCells方法定位到空白单元格后一次性删除其所在的行。
        关于Replace方法和SpecialCells方法请参阅技巧33 。
        运行Methods过程，消息框显示两种方法的运行时间，可以看出使用Replace方法和SpecialCells方法的运行时间要远远小于使用VBA代码运行的时间，如图所示。
       
袁版主：您好！ 非常感谢您一起以来辛苦地为我们大家作贡献！
多谢ykx042907，PDF要使用压缩软件压缩后上传，体积超过2000KB需要分卷压缩后上传。
建议再等等，计划到200个技巧结束，到时上传完整的吧。

第11部分 其他应用
技巧190 优化代码

190-4 使用With语句引用对象

在需要重复引用同一个对象时可以使用With语句来获得较快的运行速度，如下面的代码所示。

  Sub WithSta()
      Dim i As Integer
      Dim t As Date
      Dim t1 As String
      Dim t2 As String
      t = Timer
      For i = 1 To 5000
          Sheets("Sheet1").Cells(1, 1) = 10
          Sheets("Sheet1").Cells(1, 2) = 10
          Sheets("Sheet1").Cells(1, 3) = 10
          Sheets("Sheet1").Cells(1, 4) = 10
          Sheets("Sheet1").Cells(1, 5) = 10
      Next
      t1 = Timer - t
      t = Timer
      With Sheets("Sheet1")
          For i = 1 To 5000
              .Cells(1, 1) = 10
              .Cells(1, 2) = 10
              .Cells(1, 3) = 10
              .Cells(1, 4) = 10
              .Cells(1, 5) = 10
          Next
      End With
      t2 = Timer - t
      MsgBox "第一次运行时间:" & Format(t1, "0.00000") & "秒" _
           & Chr(13) & "第二次运行时间:" & Format(t2, "0.00000") & "秒"
  End Sub
      WithSta过程在单元格填充时使用With语句来引用工作表对象从而获得较快的运行速度。
       With语句在一个单一对象或一个用户定义类型上执行一系列的语句，语法如下： With Object [statements] End With 参数object是必需的，一个对象或用户自定义类型的名称。
        参数statements是可选的，要执行的一条或多条语句。
        With语句可以对某个对象执行一系列的语句，而不用重复指出对象的名称。
在运行时只需引用对象一次而不是在每个属性赋值时都要引用，从而获得较快的运行速度。
        运行WithSta过程，消息框显示两种方法的运行时间，可以看出使用With语句来引用工作表对象的运行速度较快，如图所示。
       
第11部分 其他应用
技巧190 优化代码

190-5 少用激活或选择语句

在学习VBA的过程中我们经常通过录制新宏的方法来获得所需的代码，但是在录制宏的过程中会记录所有的动作，代码中有大量的Select和Activate语句，而这些代码往往是不必要而且会影响代码的运行速度。
所以通过录制新宏的方法获得的代码在使用时需要进行修改以加快运行速度，如下面的代码所示。

  Sub Sta()
      Dim i As Integer
      Dim t As Date
      Dim t1 As String
      Dim t2 As String
      t = Timer
      For i = 1 To 5000
          Sheets("Sheet2").Select
          Range("A1").Select
          ActiveCell.FormulaR1C1 = "1"
      Next
      t1 = Timer - t
      t = Timer
      For i = 1 To 5000
          Sheets("Sheet2").Range("A1") = 1
      Next
      t2 = Timer - t
      MsgBox "第一次运行时间:" & Format(t1, "0.00000") & "秒" _
           & Chr(13) & "第二次运行时间:" & Format(t2, "0.00000") & "秒"
  End Sub
       Sta过程分别使用录制宏所得的代码和修改后的代码给单元格填充，最后使用消息显示运行时间。
        第8行代码到第10行代码是录制宏所得的代码，其中有两次使用Select方法，第15行代码是修改后的代码，在代码量不大的情况下运行速度区别不大，但是在循环5000次后运行速度就会差别很大。
        运行Sta过程，消息框显示两种方法的运行时间，可以看出后一种方法的运行时间要远远小于录制宏所得的代码的运行时间，如图所示。
       

第11部分 其他应用
技巧191 取得文件的基本名称 技巧77-2中介绍了如何使用Excel内置的“打开”对话框来获得选定文件的文件名称，此名称包含文件路径及文件扩展名，有时在操作时只需要文件的基本名称，此时可以使用GetBaseName方法，如下面的代码所示。

  Sub GetName()
      Dim MyFile As Object
      Dim Filename As Variant
      Set MyFile = CreateObject("Scripting.FileSystemObject")
      Filename = Application.GetOpenFilename
      If Filename <> False Then
          MsgBox MyFile.GetBaseName(Filename)
      End If
  End Sub
       GetName过程取得用户选定文件的基本文件名称。
        第4行代码使用CreateObject函数创建FileSystemObject对象并将该对象赋给变量MyFile，请参阅技巧180 。
        第5行代码使用GetOpenFilename方法显示标准的内置“打开”对话框，请参阅技巧77-2。
        第6行到第8行代码，如果用户选定了文件，使用消息框显示选定文件的基本名称。
应用于FileSystemObject对象的GetBaseName方法返回一个包含路径中最后部件的基本名字（去掉任何文件扩展名）的字符串，语法如下： object.GetBaseName(path)
       参数object是必需的，FileSystemObject对象的名称。
        参数path是必需的，要返回其基本名字的部件的路径说明。
        注意 GetBaseName方法只对参数path提供的字符串起作用，既不试图去辨认路径，也不检查指定路径是否存在。
       
第11部分 其他应用
技巧192 防止用户中断代码运行 在使用VBA开发的程序交予用户使用后，如果在运行需要长时间执行的宏代码时，用户在代码运行期间按下了<Esc>键或者<Ctrl+Break>组合键，会显示如图所示的消息框。
               此时单击“继续”按钮将继续执行代码，单击“结束”按钮结束过程，单击“调试”按钮进入中断模式，这显然不是用户所希望出现的，此时需要使用Application对象的EnableCancelKey属性来进行控制，如下面的代码所示。

  Sub EnablEsc()
      Dim i As Integer
      Application.EnableCancelKey = xlDisabled
      For i = 1 To 2000
          Cells(1, 1) = i
      Next
  End Sub
       EnablEsc过程在代码运行期间禁用“取消”键的捕获功能。
        应用于Application对象的EnableCancelKey属性控制将用户中断用于运行程序的处理，语法如下： expression.EnableCancelKey 参数是expression必需的，Application对象。
        EnableCancelKey属性值为表格所示的XlEnableCancelKey常量之一。
               只要Microsoft Excel返回空闲状态并且没有程序处于运行状态，EnableCancelKey属性都会重置为xlInterrupt。
若要在程序运行中捕获或者禁用取消过程，则每次在程序被调用时必须明确更改EnableCancelKey属性。

我找不到从什么在方下载楼主说的这些资料
Snap1.jpg
这么多，真的有人都记忆下来了？？
这个无需都记忆下来，说实话我也记不住，只需记住解决哪些问题要用到哪些方法就行了，需要的时候再去找具体的代码，这也是我整理这些技巧的初衷。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=36
本帖已被收录到知识树中，索引项：开发帮助和教程
扩展名为xls的是2003版本，xlsm是2007版本的，2007我没用过，不是太清楚。

第11部分 其他应用
我们学习VBA的目的就是学以致用，简化日常工作，提高工作效率。
下面介绍一些本人正在使用的实例，这些实例虽然只是行业应用，并不具备通用性，但对大家如何使用VBA制作适合自己的应用系统具有一定的借鉴作用。
具体的代码就不一一解析了，大家会发现这些代码在上面的技巧中基本都能找到，主要解析制作的思路和过程，供大家参考。

技巧193 加班费计算表 财务人员在工作中经常需要计算职工的加班费，在计算过程中需要根据职工的技能工资、岗位工资之和除以21天得到日工资标准，再根据当月的加班天数乘以相应的系数才能计算出加班费总额，计算时非常的烦琐，很不方便。
使用Excel制作的加班费计算表可以很方便的计算职工的加班费。
        步骤1，新建工作簿，将Sheet2工作表重命名为“人员信息”，在第一行中写入所需信息的字段名称，如图所示。

       步骤2，所需的人员信息无需在工作表中一一输入，前四个可以从工资软件中导出的文本文件中获取，后两个可以使用代码自动生成。
在VBE窗口中插入模块，写入下面的代码。

  Sub ImportWages()
      Dim GetName As Variant
      Dim TxtPath As String
      Dim TxtName As String
      Dim Tbtext As String
      Dim sField As String
      Dim Cnn As ADODB.Connection
      Dim rs As New ADODB.Recordset
      Dim r As Integer
      Dim i As Integer
      Dim b As Integer
      Dim StrName As String
      If MsgBox("是否重新导入工资表数据?", vbQuestion + vbYesNo, "系统提示") = vbNo Then: Exit Sub
      On Error GoTo line
      GetName = Application.GetOpenFilename(Title:="导入工资", fileFilter:="All files (*.*),*.*")
      With Sheet2
          .Select
          .Unprotect
          If GetName <> False Then
              TxtPath = CreateObject("Scripting.FileSystemObject").GetParentFolderName(GetName)
              TxtName = CreateObject("Scripting.FileSystemObject").GetFileName(GetName)
              Tbtext = " [Text;DATABASE=" & TxtPath & "]." & TxtName
              Set Cnn = New ADODB.Connection
              Cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes';data source=" & ThisWorkbook.FullName
              rs.Open "select 人员编号,姓名,技能工资,岗位工资 from " & Tbtext, Cnn
              r = .Range("A65536").End(xlUp).Row
              If r >= 3 Then .Range("A3:F" & r).ClearContents
              .Range("A3").CopyFromRecordset rs
              r = .Range("A65536").End(xlUp).Row
              .Range("A" & r & ":F" & r).ClearContents
              For i = 3 To r
                  StrName = ""
                  For b = 1 To Len(.Cells(i, 2))
                      If Asc(Mid$(.Cells(i, 2), b, 1)) > 255 Or Asc(Mid$(.Cells(i, 2), b, 1)) < 0 Then
                          StrName = StrName & LChin(Mid$(.Cells(i, 2), b, 1))
                      Else
                          StrName = StrName & LCase(Mid$(.Cells(i, 2), b, 1))
                      End If
                  Next b
                  .Cells(i, 5) = Round((Val(.Cells(i, 3)) + Val(.Cells(i, 4))) / 21, 2)
                  .Cells(i, 6) = StrName
              Next i
          End If
          .Protect
      End With
      Exit Sub
  line:
      MsgBox "请选择正确的文本文件!", 64, "系统提示"
  End Sub
       ImportWages过程从工资软件导出的文本文件中导入人员的工资信息并计算日工资、生成助记码。
        第13行代码，确认是否需要重新导入工资信息。
        第14行代码，错误处理语句。
在第25行代码中，如果打开的文件不是从工资软件中导出的文本文件，会因找不到所查询的字段名称而发生错误。
        第15行代码，使用GetOpenFilename方法显示“打开”对话框，用来获得从工资软件中导出的文本文件的文件路径。
关于GetOpenFilename方法请参阅77-2。
        第18行代码，取消Sheet2表的工作表保护。
        第19行到第21行代码，如果在“打开”对话框中选择了文件并按下了“打开”按钮使用GetParentFolderName方法将返回的路径中的文件路径赋给字符串变量TxtPath，使用GetFileName方法将返回的路径中的包含扩展名的文件名称赋给字符串变量TxtName。
关于FileSystemObject对象的一些方法请参阅技巧180 。
        第22行到第25行代码，使用ADO语句从选择文本文件中查询需要的数据。
其中第25行代码设置需查询数据的字段名称。
        第26、27行代码，使用ClearContents方法清除表中原来的数据。
        第28行代码，将查询到数据写入到工作表中。
        第29、30行代码，使用ClearContents方法清除导入数据的最后一行，即最后的合计行。
        第31行到第39行代码，根据B列中的人员姓名生成助记码，方便在使用时输入人员姓名。
请参阅技巧114 。
        第40行代码，根据C列的技能工资和D列的岗位工资计算日工资标准并写入到E列中。
        第41行代码，将生成的人员姓名助记码写入到F列中。
        第44行代码，使用Protect方法保护Sheet2表。
        第48行代码，如果文件选择错误，使用消息框进行提示。
        运行ImportWages过程将显示一个“打开”对话框用来获得需打开的工资表文件的路径及文件名称，如图所示。

       当选择好最新的工资表文件后单击“打开”按钮，将最新的工资数据导入到Sheet2表中，如图所示。

      在ImportWages过程的第35行代码使用自定义LChin函数将中文字符转换为拼音首字母，需要在模块中写入下面的代码。

  Public Function LChin(Str As String) As Variant
      On Error Resume Next
      Str = StrConv(Str, vbNarrow)
      If Asc(Str) > 0 Or Err.Number = 1004 Then LChin = ""
      LChin = WorksheetFunction.VLookup(Str, [{"吖","a";"八","b";"嚓","c";"咑","d";"鵽","e";"发","f";"猤","g";"铪","h";"夻","j";"咔","k";"垃","l";"嘸","m";"旀","n";"噢","o";"妑","p";"七","q";"囕","r";"仨","s";"他","t";"屲","w";"夕","x";"丫","y";"帀","z"}], 2)
  End Function

步骤3，将Sheet1工作表重命名为“加班费计算”并设置成如图所示。

       步骤4，为了方便输入人员姓名，需要输入时能逐步提示信息，而工作表的单元格处于编辑状态时是无法运行宏代码，所以需要在Sheet1表中添加一个文本框控件和一个列表框控件，文本框用来代替单元格进行输入，列表框显示提示的信息。
        为了使文本框控件和列表框控件只有在需要输入人员姓名时显示，在Sheet1表写入下面的代码。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Dim i As Integer
      Dim r As Integer
      Dim arr As Variant
      r = Sheet1.Range("B63556").End(xlUp).Row
      If Target.Count = 1 Then
          If Target.Column = 2 And Target.Row > 4 And Target.Row < r Then
              If Target.Row = r - 1 Then
                  Sheet1.Unprotect
                  Rows(r).Insert Shift:=xlDown
                  Sheet1.Protect
              End If
              With Me.TextBox1
                  .Visible = True
                  .Top = Target.Top
                  .Left = Target.Left
                  .Width = Target.Width
                  .Height = Target.Height
              End With
              With Me.ListBox1
                  .Visible = True
                  .Top = Target.Top
                  .Left = Target.Offset(, 1).Left
                  .Width = 80
                  .Height = Target.Height * 8
                  .ColumnCount = 2
                  .ColumnWidths = "30,45"
                  arr = Sheet2.Range("A3:B" & Sheet2.[B63556].End(xlUp).Row)
                  .Column = Application.WorksheetFunction.Transpose(arr)
              End With
          Else
              Me.ListBox1.Clear
              Me.TextBox1 = ""
              Me.ListBox1.Visible = False
              Me.TextBox1.Visible = False
          End If
      End If
  End Sub
       工作表的SelectionChange事件，当选择工作表的B列单元格时显示文本框控件和列表框控件供输入人员姓名。
请参阅技巧114 中的相关内容。
        当选择Sheet1表的B列单元格时效果如图所示。

       为了输入时能逐步提示信息，在文本框控件和列表框控件中写入下面的代码。

  Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      Dim i As Integer
      Dim Language As String
      Dim myStr As String
      Me.ListBox1.Clear
      With Me.TextBox1
          For i = 1 To Len(.Value)
              Select Case Asc(Mid$(.Value, i, 1))
                  Case 48 To 56
                      Language = "S"
                      myStr = myStr & Mid$(.Value, i, 1)
                  Case Is < 0, Is > 255
                      Language = "Z"
                      myStr = myStr & Mid$(.Value, i, 1)
                  Case Else
                      Language = "P"
                      myStr = myStr & LCase(Mid$(.Value, i, 1))
              End Select
          Next
      End With
      With Sheet2
          For i = 3 To .Range("A65536").End(xlUp).Row
              Select Case Language
                  Case "S"
                      If Left(.Cells(i, 1).Value, Len(myStr)) = myStr Then
                          Me.ListBox1.AddItem
                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = .Cells(i, 1).Value
                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = .Cells(i, 2).Value
                      End If
                  Case "Z"
                      If Left(.Cells(i, 2).Value, Len(myStr)) = myStr Then
                          Me.ListBox1.AddItem
                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = .Cells(i, 1).Value
                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = .Cells(i, 2).Value
                      End If
                  Case Else
                      If Left(.Cells(i, 6).Value, Len(myStr)) = myStr Then
                          Me.ListBox1.AddItem
                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = .Cells(i, 1).Value
                          Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = .Cells(i, 2).Value
                      End If
              End Select
          Next
      End With
  End Sub
       文本框的KeyUp事件，在文本框中输入姓名时根据输入的内容进行逐步提示，可以使用三种方法进行输入，人员编号、中文字符和拼音首字母。
        第7行到第19行代码，使用字符串变量Language保存输入的方式，字符串变量myStr保存输入的内容。
        第21行到第42行代码，根据输入方法的不同，在Sheet2表的不同列中查找符合字符串变量myStr的单元格，并赋给列表框控件。

  Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      If KeyCode = vbKeyReturn Then
          Sheet1.ListBox1.Activate
      End If
  End Sub
       文本框的KeyDown事件，在文本框中输入查询条件，当列表框中出现符合条件的数据后按回车键后选择列表框，方便输入。

  Private Sub ListBox1_GotFocus()
      On Error Resume Next
      ListBox1.ListIndex = 0
  End Sub
       列表框的GotFocus事件，当列表框激活后选择第一条条目，以便用户按上下键进行选择或按回车键后输入到工作表中。

  Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
      On Error Resume Next
      If KeyCode = vbKeyReturn Then
          Sheet1.Unprotect
          ActiveCell.Value = Me.ListBox1.Column(1)
          ActiveCell.Offset(, -1).Value = Me.ListBox1.Column(0)
          Me.ListBox1.Clear
          Me.TextBox1 = ""
          Me.ListBox1.Visible = False
          Me.TextBox1.Visible = False
          Sheet1.Protect
      End If
  End Sub
       列表框的KeyDown事件，按回车键后将列表框中选择的条目输入到工作表中，并清除文本框和列表框的内容后隐藏，以便下一次输入。

  Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
      On Error Resume Next
      Sheet1.Unprotect
      ActiveCell.Value = Me.ListBox1.Column(1)
      ActiveCell.Offset(, -1).Value = Me.ListBox1.Column(0)
      Me.ListBox1.Clear
      Me.TextBox1 = ""
      Me.ListBox1.Visible = False
      Me.TextBox1.Visible = False
      Sheet1.Protect
  End Sub
       列表框的DblClick事件，双击列表框中选择的条目，输入到工作表中，并清除文本框和列表框的内容后隐藏，以便下一次输入。
输入时逐步提示信息请参阅技巧114 。

步骤5，为了在输入人员姓名后在Sheet1工作表的C列中写入相应的日工资标准，在Sheet1工作表的写入下面的代码。

  Private Sub Worksheet_Change(ByVal Target As Range)
      Dim rng As Range
      Dim r As Integer
      On Error Resume Next
      With Target
          If .Row > 4 And .Count = 1 Then
              If .Column = 1 Then
                  r = Sheet2.Range("A63556").End(xlUp).Row
                  For Each rng In Sheet2.Range("A3:A" & r)
                      If rng.Text Like .Text Then
                          .Offset(, 2).Value = rng.Offset(, 4).Value
                      End If
                  Next
              End If
              If .Column = 2 Then
                  If .Text = "" Then
                      Application.EnableEvents = False
                      Sheet1.Unprotect
                      Rows(.Row).Delete
                      Sheet1.Protect
                      Application.EnableEvents = True
                  End If
              End If
              
          End If
      End With
  End Sub
       Sheet1工作表的Change事件，当输入人员编号和人员姓名后，将对应的日工资标准写入到Sheet1工作表的C列中。
        第6行代码设置事件的触发条件。
        第7行到第14行代码，删除B列单元格中的人员姓名则同时删除对应的人员编号和日工资标准。
        第18行到第29行代码，检查输入的人员姓名是否重复。
因为单位中可能有重复的人员姓名，但是人员编号是唯一的，所以根据人员编号检查输入的人员姓名是否重复。
        第30行到第34行代码，使用Like方法在根据人员编号在Sheet2表的A列中查找相对应的人员编号，找到后将日工资标准写入到Sheet1工作表的C列中。
        在Sheet1工作表的B列中输入人员姓名后效果如图所示。

       步骤6，在某些情况下，可能需要输入全部人员的姓名，比如在笔者单位每年的7、8月份要发放高温加班工资，这时可以从Sheet2表中将所有人员的姓名和编号导入到Sheet1表中，需要在模块中写入下面的代码。

  Sub ImportName()
      Dim r1 As Integer
      Dim r2 As Integer
      Dim i As Long
      r1 = Sheet1.Range("B63556").End(xlUp).Row
      r2 = Sheet2.Range("B63556").End(xlUp).Row
      If MsgBox("确定要导入所有人员姓名吗", 32 + vbYesNo, "系统提示") = vbNo Then Exit Sub
      Application.ScreenUpdating = False
      With Sheet1
          .Select
          .Unprotect
          If r1 <= r2 + 3 Then .Rows(r1).Resize(r2 - r1 + 4).Insert
          For i = 5 To Sheet1.Range("B63556").End(xlUp).Row - 2
              .Cells(i, 1) = Sheet2.Cells(i - 2, 1)
              .Cells(i, 2) = Sheet2.Cells(i - 2, 2)
          Next
          .Protect
      End With
      Application.ScreenUpdating = True
  End Sub
       ImportName过程将Sheet2工作表的人员姓名导入到Sheet1工作表的B列单元格中。
        第5、6行代码，取得两个工作表中现有数据的行号。
        第12行代码，根据两个工作表中现有数据的行号决定在到Sheet1工作表需要插入的行数。
        第13行第16行代码，将Sheet2工作表的人员编号和人员姓名导入到Sheet1工作表的B列单元格中，因为在写入的过程中同时会触发工作表的Change事件，所以日工资标准无需导入。
        如果有少量不需要计算的人员姓名可以在导入后删除。
        步骤7，如果在输入时Sheet1工作表中已有数据，可以先进行清除，在模块中写入下面的代码。

  Sub DataClear()
      Dim r As Integer
      With Sheet1
          .Select
          If MsgBox("是否清除加班费数据?", 32 + vbYesNo, "系统提示") = vbNo Then Exit Sub
          .Unprotect
          r = .Range("B63556").End(xlUp).Row
          If r >= 6 Then
              .Rows("5:" & r - 2).Delete
          End If
          r = .Range("B63556").End(xlUp).Row
          Union(.Cells(2, 12), .Range(.Cells(r, 5), .Cells(r, 12))).ClearContents
          .Protect
          Application.GoTo Reference:=.Cells(5, 4), Scroll:=True
      End With
  End Sub
       DataClear过程清除计算表中已有的数据。
        步骤8，在VBE中插入一个窗体，用于计算加班费时选择计算的月份并对Sheet2表的D、F、H和J列中输入的加班班数计算应发的加班费合计，如图所示。
                 双击窗体写入下面的代码。

  Private Sub UserForm_Initialize()
      SpinButton1.Value = Year(Date)
      SpinButton2.Value = Month(Date)
      TextBox1.Text = Year(Date) & "年"
      TextBox2.Text = Month(Date) & "月份"
  End Sub
       窗体的Initialize事件，在窗体初始化时文本框中显示当前的年月。
        双击窗体中的SpinButton控件，写入下面的代码。

  Private Sub SpinButton1_Change()
      TextBox1.Text = SpinButton1.Value & "年"
  End Sub
  Private Sub SpinButton2_Change()
      With SpinButton2
          Select Case .Value
              Case 1 To 12
                  TextBox2.Text = .Value & "月份"
              Case Is > 12
                  TextBox1.Text = Left(TextBox1.Text, 4) + 1 & "年"
                  .Value = 1
              Case Is < 1
                  TextBox1.Text = Left(TextBox1.Text, 4) - 1 & "年"
                  .Value = 12
          End Select
      End With
  End Sub
       使用SpinButton控件调节窗体中显示的年月，请参阅技巧140 。
        双击窗体中的“确定”按钮，写入下面的代码。

  Private Sub CommandButton1_Click()
      Dim i As Integer
      Dim r As Integer
      With Sheet1
          .Select
          r = .Range("B63556").End(xlUp).Row
          If .Cells(5, 2) = "" Then
              MsgBox "请把数据填写完整后再计算!", 64, "系统提示"
              Unload Me
              Exit Sub
          End If
          For i = 5 To r - 2
              If WorksheetFunction.CountIf(.Range("B5:B" & i), .Cells(i, 2)) > 1 Then
                  If MsgBox(.Cells(i, 2) & "输入重复,是否继续?", 36, "系统提示") = 7 Then
                      Unload Me
                      Exit Sub
                  End If
              End If
          Next
          .Unprotect
          .Cells(2, 12) = TextBox2.Text
          For i = 5 To r - 1
              .Cells(i, 5) = Round(100 * .Cells(i, 4), 2)
              .Cells(i, 7) = Round(.Cells(i, 3) * 1.5 * .Cells(i, 6), 2)
              .Cells(i, 9) = Round(.Cells(i, 3) * 2 * .Cells(i, 8), 2)
              .Cells(i, 11) = Round(.Cells(i, 3) * 3 * .Cells(i, 10), 2)
              .Cells(i, 12) = .Cells(i, 5) + .Cells(i, 7) + .Cells(i, 9) + .Cells(i, 11)
          Next
              .Cells(r, 5) = WorksheetFunction.Sum(.Range("E5:E" & r - 1))
              .Cells(r, 7) = WorksheetFunction.Sum(.Range("G5:G" & r - 1))
              .Cells(r, 9) = WorksheetFunction.Sum(.Range("I5:I" & r - 1))
              .Cells(r, 11) = WorksheetFunction.Sum(.Range("K5:K" & r - 1))
              .Cells(r, 12) = WorksheetFunction.Sum(.Range("L5:L" & r - 1))
          .Protect
      End With
      Unload Me
      MsgBox TextBox1.Text & TextBox2.Text & "的加班费已计算完毕!", 64, "系统提示"
  End Sub
       窗体中的“确定”按钮的Click事件过程，计算Sheet1表中的加班费合计。
        第7行到第11行代码，检查Sheet1表中是否已输入人员姓名及加班班数。
        第12行到第19行代码，检查Sheet1表中的人员编号是否重复。
        第21行代码，在Sheet1表中写入所计算的月份。
        第22行到第28行代码，根据加班班数和相应的系数计算加班费金额。
        第29行到第33行代码，计算合计栏的金额。
        在Sheet1表中输入人员姓名和加班天数后按窗体的“确定”按钮后效果如图所示。

       为了计算高温加班工资，VBE中插入一个和计算加班费类似的窗体，双击窗体中的“确定”按钮，写入下面的代码。

  Private Sub CommandButton1_Click()
      Dim rng As Range
      Dim i As Integer
      Dim r As Integer
      With Sheet1
          r = .Range("B63556").End(xlUp).Row
          .Select
          If .Cells(5, 2) = "" Then
              MsgBox "请把数据填写完整后再计算!", 64, "系统提示"
              Unload Me
              Exit Sub
          End If
          For i = 5 To r - 2
              If WorksheetFunction.CountIf(.Range("B5:B" & i), .Cells(i, 2)) > 1 Then
                  If MsgBox(.Cells(i, 2) & "输入重复,是否继续?", 36, "系统提示") = 7 Then
                      Unload Me
                      Exit Sub
                  End If
              End If
          Next
          Application.ScreenUpdating = False
          .Unprotect
          .Cells(2, 12) = TextBox2.Text
          With Sheet2.Range("A:A")
              For i = 5 To r - 1
                  Set rng = .Find(What:=Cells(i, 1).Value, _
                      After:=.Cells(.Cells.Count), _
                      LookIn:=xlFormulas, _
                      LookAt:=xlWhole, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False)
                  If Not rng Is Nothing Then
                      Sheet1.Cells(i, 12) = Round(((Val(rng.Offset(0, 2)) + Val(rng.Offset(0, 3))) / 2), 2)
                  End If
              Next
          End With
          .Cells(r, 12) = WorksheetFunction.Sum(.Range("L5:L" & r - 1))
          .Protect
      End With
      Application.ScreenUpdating = True
      Unload Me
      MsgBox TextBox1.Text & TextBox2.Text & "的高温工资计算完毕!", 64, "系统提示"
  End Sub
       窗体中的“确定”按钮的Click事件过程，计算Sheet1表中的高温工资。
        第8行到第12行代码，检查Sheet1表中是否已输入人员姓名。
        第13行到第20行代码，检查Sheet1表中的人员编号是否重复。
        第23行代码，在Sheet1表中写入所计算的月份。
        第24行到第37行代码，根据Sheet1表中的人员编号在Sheet2表中查找对应的“技能工资”和“岗位工资”并将其合计数的二分之一写入到Sheet1表中。
（笔者所在单位每年发一次高温加班工资，为职工“技能工资”和“岗位工资”之和，分两个月发放） 第38行代码，计算合计栏的金额。
        在Sheet1表中输入人员姓名和加班天数后按窗体的“确定”按钮后效果如图所示。

步骤8，加班费计算完毕后，需要进行汇总，以便统计全年的加班费总额。
将Sheet3工作表重命名为“加班费汇总”并设置成如图所示的格式，在A列和B列中分别写入人员编号和姓名。

       在模块中写入下面的代码。

  Sub DataSummary()
      Dim MyMonth As String
      Dim c As Integer
      Dim rng As Range
      Dim r As Integer
      Dim i As Integer
      MyMonth = Sheet1.Cells(2, 12).Value
      If MsgBox("是否汇总加班费数据?", 36, "系统提示") = 7 Then
          Exit Sub
      End If
      If Sheet1.Cells(5, 12) = "" Then
          MsgBox "没有可汇总的数据,请先计算加班费!", 64, "系统提示"
          Exit Sub
      End If
      With Sheet3
          r = .Range("A63556").End(xlUp).Row
          For i = 3 To 14
              If .Cells(1, i).Value = MyMonth Then
                  c = i
                  Exit For
              End If
          Next
          If .Cells(r, c).Value > 0 Then
              If MsgBox(MyMonth & "加班费已经汇总,是否继续?", 36, "系统提示") = 7 Then
              Exit Sub
          End If
          End If
          .Unprotect
          Application.ScreenUpdating = False
          With .Range("A:A")
              For i = 5 To Sheet1.Range("A63556").End(xlUp).Row
                  Set rng = .Find(What:=Sheet1.Cells(i, 1).Text, _
                      After:=.Cells(.Cells.Count), _
                      LookIn:=xlFormulas, _
                      LookAt:=xlWhole, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False)
                  If Not rng Is Nothing Then
                      rng.Offset(, c - 1) = Val(rng.Offset(, c - 1)) + Val(Sheet1.Cells(i, 12))
                  End If
              Next
          End With
         .Cells(r, c).ClearContents
          For i = 2 To r - 1
              .Cells(r, c) = Val(.Cells(r, c)) + Val(.Cells(i, c))
          Next
          For i = 2 To r
              .Cells(i, 15) = WorksheetFunction.Sum(.Range("C" & i & ":N" & i))
          Next
          Application.GoTo Reference:=.Cells(1, c), Scroll:=True
          .Protect
      End With
      Application.ScreenUpdating = True
      MsgBox MyMonth & "的加班费汇总完毕!", 64, "系统提示"
  End Sub
       DataSummary过程将“加班费计算”表中计算好的加班费合计汇总到“加班费汇总”表中。
        第8行代码获得需要汇总的月份。
        第17行到第22行代码，获得需要汇总的月份在“加班费汇总”表中的列号。
        第23行代码到第27行代码，如果“加班费汇总”表中相应的列中已有合计金额，询问是否继续汇总，防止重复汇总。
        第30行到第43行代码，使用Find方法将加班费金额进行汇总。
关于Find方法请参阅技巧5-1。
        第44行到第50行代码在汇总表中重新计算每行每列的合计数。
        第51行代码使用GoTo方法选择汇总表中相应的单元格。
关于GoTo方法请参阅技巧2-3。
        步骤9，加班费计算、汇总完毕后需要进行打印，首先在工作表窗口中单击菜单“文件”→“页面设置”，在“工作表”选项卡中将“顶端标题行”设置为“$1:$4”，然后在VBE中插入一个窗体，如图所示。
               双击窗体中的“打印”按钮，写入下面的代码。

  Private Sub CommandButton1_Click()
      Dim r As Byte
      Dim i As Integer
      Dim i1 As Integer
      Dim i2 As Integer
      Application.ScreenUpdating = False
      ActiveWindow.View = xlPageBreakPreview
      With Sheet1
          r = .Range("B65536").End(xlUp).Row
          .ResetAllPageBreaks
          If .HPageBreaks.Count = 0 Then
              .Unprotect
              .Cells(100, 2) = "123"
              i1 = .HPageBreaks(1).Location.Row
              .Cells(100, 2) = ""
              .Unprotect
              For i = r To i1 - 2
                  .Rows(r).Insert
              Next
              .Protect
          Else
              .HPageBreaks.Add Before:=.Range("B65536").End(xlUp).Offset(1, 0)
              i1 = .HPageBreaks(1).Location.Row - 5
              i2 = .HPageBreaks(.HPageBreaks.Count).Location.Row - .HPageBreaks(.HPageBreaks.Count - 1).Location.Row
              .Unprotect
              For i = 1 To i1 - i2
                  .HPageBreaks(.HPageBreaks.Count).Location.Offset(-1, 0).EntireRow.Insert
              Next
              .Protect
          End If
      End With
      ActiveWindow.View = xlNormalView
      Application.ScreenUpdating = True
      Unload Me
      Sheet1.PrintOut Copies:=ComboBox1.Value
  End Sub
       打印窗体中 “打印”按钮的Click事件过程，打印“加班费计算表”。
        第7行代码，将窗口中的视图设置为分页预览。
应用于Window对象的View属性返回或设置在窗口中显示的视图，设置成xlPageBreakPreview为分页预览，xlNormalView则为普通视图。
        第11行代码，判断Sheet1表是否满页。
HPageBreaks属性返回 HPageBreaks集合，代表工作表上的水平分页符，如果工作表中没有水平分页符说明没有满页。
        第13行到第15行代码，在B列单元格中写入字符取得Sheet1表中第一个分页符的位置后再删除。
        第17行到第19行代码，在Sheet1表中的B列合计栏中插入一定数量的空行使其满页。
        第22行代码，如果Sheet1表的打印内容不止一页，在最后一行插入一个分页符。
        第23行代码，取得Sheet1表中满页的行数。
        第24行代码，取得Sheet1表最后一页中的行数，两者相减即能得到最后一页中需插入的行数。
        第26行到第28行代码，在Sheet1表中的B列合计栏中插入一定数量的空行使其满页。
        第32行代码，将窗口中的视图设置为普通视图。
        当使用“打印”窗体打印Sheet1表时，将自动插入一定数量的空行使其满页打印。
        步骤10，为了使用方便，需要在菜单栏中添加自定义菜单来使用各项功能，在模块中写入下面的代码。

  Sub AddNewMenu()
      Dim HelpMenu As CommandBarControl
      Dim NewMenu As CommandBarPopup
      With Application.CommandBars("Worksheet menu bar")
          .Reset
          Set HelpMenu = .FindControl(ID:=.Controls("帮助(&H)").ID)
          If HelpMenu Is Nothing Then
              Set NewMenu = .Controls.Add(Type:=msoControlPopup)
          Else
              Set NewMenu = .Controls.Add(Type:=msoControlPopup, Before:=HelpMenu.Index)
          End If
          With NewMenu
              .Caption = "加班费(&S)"
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "导入数据"
                  .OnAction = "ImportWages"
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "清除加班费"
                  .OnAction = "DataClear"
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "批量导入人员"
                  .OnAction = "ImportName"
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "计算加班费"
                  .OnAction = "DataCalculation"
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "计算高温工资"
                  .OnAction = "TemperatureCalculation"
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "加班费汇总"
                  .OnAction = "DataSummary"
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "打印加班费"
                  .OnAction = "HPageBreak"
              End With
          End With
      End With
      Set HelpMenu = Nothing
      Set NewMenu = Nothing
  End Sub
  Sub DelNewMenu()
      Application.CommandBars("Worksheet menu bar").Reset
  End Sub
       AddNewMenu过程在“帮助”菜单前添加一个自定义的“加班费”菜单。
        DelNewMenu过程删除自定义的“加班费”菜单。
        为了工作簿打开时自动添加“加班费”菜单和关闭时自动删除“加班费”菜单，需要在VBE中双击ThisWorkbook写入下面的代码。

  Private Sub Workbook_Activate()
      Call AddNewMenu
  End Sub
  Private Sub Workbook_Deactivate()
      Call DelNewMenu
  End Sub
       保存关闭工作簿，重新打开，将在菜单栏中添加自定义的“加班费”菜单，可以方便的使用加班费计算表中的各项功能，如图所示。

第11部分 其他应用
技巧194 制作发放条 虽然大多数企业的工资核算都已使用了专业软件，但是有些不能上工资表的项目还是需要使用Excel来制作发放表，比如如图所示的奖金发放表，这时往往需要提供发放条给每一个职工。

制作发放条的方法有很多，其中使用VBA制作发放条是最方便快捷的，如下面的代码 所示。

  Sub Printissued()
      Dim r As Integer
      Dim Sh As Worksheet
      Dim i As Integer
      Application.ScreenUpdating = False
      r = Sheet1.Range("B65536").End(xlUp).Row
      With Worksheets
          Set Sh = .Add(after:=Worksheets(.Count))
      End With
      With Sh
          Sheet1.Range("A1:K" & r).Copy .Range("A1")
          .Range("A5:K" & r) = Sheet1.Range("A5:K" & r).Value
          .Range("F2,K2") = ""
          With .PageSetup
              .PrintTitleRows = "$1:$1"
              .LeftMargin = Application.CentimetersToPoints(1)
              .RightMargin = Application.CentimetersToPoints(1)
              .CenterHorizontally = True
          End With
          For i = 1 To r
              .Rows(i).RowHeight = Sheet1.Rows(i).RowHeight
          Next
          For i = 1 To 11
              Columns(i).ColumnWidth = Sheet1.Columns(i).ColumnWidth
          Next
          r = .Range("B65536").End(xlUp).Row
          For i = r To 6 Step -1
              .Rows("2:4").Copy
              .Rows(i).Insert Shift:=xlDown
          Next
          Application.CutCopyMode = False
          ActiveWindow.View = xlPageBreakPreview
          For i = 1 To .HPageBreaks.Count
              If .HPageBreaks(i).Location.Offset(-1, 0) <> "" Then
                  .HPageBreaks.Add Before:=.HPageBreaks(i).Location.Offset(-2, 0)
              End If
          Next
          ActiveWindow.View = xlNormalView
          .PrintOut
          Application.DisplayAlerts = False
          .Delete
          Application.DisplayAlerts = True
      End With
      Application.ScreenUpdating = True
  End Sub
       Printissued过程将发放表以发放条的形式打印。
        第5行代码关闭屏幕刷新加快运行速度。
        第7行到第9行代码，为了不破坏原表的结构，在工作簿中新建一张工作表用来制作发放条。
        第11行代码，将发放表中需要制作发放条的区域拷贝到新工作表中。
        第12行代码，将表中的公式部分转化为数值。
        第13行代码，删除原表中的年度和人数。
        第14行到第19行代码，设置发放条表的打印标题行、左右边距及水平居中。
        第20行到第25行代码，设置发放条表的行高列宽与原表一致。
        第26行到第31行代码，在发放条的每行数据前插入表头部分。
        第32行到第38行代码，因为可能存在同一个人表头和数据不在同一页面的现象，所以逐一检查分页符，如果分页符所在单元格的上面单元格不是空白行则将分页符上移两行。
        第39行代码，使用PrintOut方法打印发放条。
        第40行到第42行代码，使用Delete方法删除发放条表。
        运行Printissued过程，发放条表没删除前如图所示。

第11部分 其他应用
技巧195 费用统计表 对于经常发生的一些费用开支，可以使用Excel进行录入和统计，比如使用本统计表可以方便的录入汽车费用明细，对费用明细按时间或类别进行统计，并以图表的形式在窗体中显示出来。
        步骤1，新建工作簿，将Sheet1表重命名为“费用明细”并设置为如图所示的格式。

       步骤2，在Sheet1工作表中单击菜单“视图”→“工具栏”→“控件工具箱”，在显示的工具栏中选择“其他附件”中的DTPicker控件，在工作表中拖动添加一个DTPicker控件。
如果“其他附件”中没有该控件，请参阅技巧118 对其进行注册。
        步骤3，在VBE中双击Sheet1，在工作表的SelectionChange事件过程中写入以下代码。

  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Dim r As Integer
      r = Sheet1.Range("B65536").End(xlUp).Row
      If Target.Row > 1 And Target.Row < r And Target.Count = 1 Then
          If Target.Column = 1 Then
              With Me.DTPicker1
                  .Visible = True
                  .Value = Date
                  .Top = Target.Top
                  .Left = Target.Left
                  .Width = Target.Width + 15
                  .Height = Target.Height
              End With
          Else
              Me.DTPicker1.Visible = False
          End If
          If Target.Column = 3 Then
              With Target.Validation
                  .Delete
                  .Add Type:=xlValidateList, _
                  AlertStyle:=xlValidAlertStop, _
                  Operator:=xlBetween, _
                  Formula1:="汽油费,过路费,保险费,修理费,保养费,装饰费,改装费,养路费,其他费"
              End With
          End If
       End If
  End Sub
       工作表的SelectionChange事件，当选择A列单元格时显示日历控件，选择C列时建立数据有效性，便于在工作表中录入时间及费用类别。
        第4行代码，设置该事件的触发条件，只有在选择第2行和“合计”行之间单元格并且只选择一个单元格时事件触发。
        第5行到第16行代码如果选择的是第一列录入日期的单元格时，显示日历控件并对其格式进行相应的设置，如图 所示，方便录入费用日期，否则隐藏日历控件。

       第17行到第26行代码如果选择的是第三列录入费用类别的单元格时，在单元格中建立数据有效性设置，如图所示。
关于在工作表中建立数据有效性请参阅12-1。

       在VBE中双击Sheet1，在工作表的Change事件过程中写入以下代码。

  Private Sub Worksheet_Change(ByVal Target As Range)
      Dim r1 As Integer
      Dim r2 As Integer
      With Sheet1
          r1 = .Range("D65536").End(xlUp).Row
          r2 = .Range("E65536").End(xlUp).Row
          If Target.Column = 4 And Target.Row > 1 And Target.Count = 1 Then
              .Range("E2:E" & r1).FormulaR1C1 = "=SUM(R2C4:RC4)"
              .Range("E2:E" & r1) = Range("E2:E" & r1).Value
              .Cells(r2, 5).FormulaR1C1 = "=SUM(R2C4:RC4)"
              .Cells(r2, 5) = .Cells(r2, 5).Value
          End If
      End With
  End Sub
       工作表的Change事件过程，当工作表的第四列单元格中录入费用金额时，在第五列“合计”单元格中写入金额合计的公式，并将公式转化为数值。
        在设计模式下双击DTPicker控件，写入下面的代码。

  Private Sub DTPicker1_CloseUp()
      ActiveCell = DTPicker1.Value
      DTPicker1.Visible = False
  End Sub
       DTPicker控件的Change事件，选择日历控件的日期时将日期写入到工作表的活动单元格中。
        步骤4，在VBE窗口中单击菜单“插入”→“用户窗体”，添加一个“统计”窗体，在窗体中添加一个ListView和一个框架控件控件，在框架控件中添加三个组合框控件、三个按钮控件和一个框架控件，在其中添加一个标签控件，如图所示。

       在VBE中双击窗体写入下面的代码。

  Private Sub UserForm_Initialize()
      Dim Col As New Collection
      Dim rng As Range, arr, Category
      Dim i As Integer
      On Error Resume Next
      For Each rng In Sheet1.Range("A2:A" & [A65536].End(xlUp).Row)
          Col.Add Left(rng, 7), Key:=CStr(Left(rng, 7))
      Next
      ReDim arr(1 To Col.Count)
      For i = 1 To Col.Count
          arr(i) = Col(i)
      Next
      Me.Frame1.ComboBox1.List = arr
      Me.Frame1.ComboBox2.List = arr
      Category = Array("汽油费", "过路费", "保险费", "修理费", "保养费", "装饰费", "其他费")
      Me.Frame1.ComboBox3.List = Category
      With Me.ListView1
          .ColumnHeaders.Clear
          .ColumnHeaders.Add , , " 日期", 55, lvwColumnLeft
          .ColumnHeaders.Add , , " 费用内容", 110, lvwColumnLeft
          .ColumnHeaders.Add , , "费用类别", 50, lvwColumnCenter
          .ColumnHeaders.Add , , "金额 ", 50, lvwColumnRight
          .ColumnHeaders.Add , , "合计 ", 60, lvwColumnRight
          .View = lvwReport
          .Gridlines = True
      End With
      Me.CommandButton3.Enabled = False
  End Sub
       窗体的Initialize事件，窗体初始化时对其中的控件进行相应的设置。
        第6行到第14行代码，使用Add方法将第一列中的日期去除重复值后取其年月添加到“开始日期”和“结束日期”组合框中，关于使用Add方法去除重复值请参阅技巧110 。
        第15、16行代码在“费用类别”组合框中添加列表项。
关于在组合框中添加列表项的方法请参阅技巧109 。
        第17行到第26行代码在ListView控件中添加标题列并进行相应的设置，请参阅技巧131 。
        第27行代码将“图表”按钮的Enabled属性设置为False，使之暂不可用。
        在VBE中双击窗体上的“统计”按钮写入下面的代码。

  Private Sub CommandButton1_Click()
      Dim StartDate As Date
      Dim EndDate As Date
      Dim r As Integer
      Dim r2 As Integer
      Dim Itm As ListItem
      Dim i As Integer
      Dim Col As New Collection
      Dim rng As Range
      Dim StrResults As String
      r = Sheet1.Range("A65536").End(xlUp).Row
      With Me.Frame1.ComboBox1
          If .Value = "" Then
              StartDate = .List(0) & "-1"
          Else
              StartDate = .Value & "-1"
          End If
      End With
      With Me.Frame1.ComboBox2
          If .Value = "" Then
              EndDate = DateSerial(Year(.List(.ListCount - 1) & "-1"), Month(.List(.ListCount - 1) & "-1") + 1, 0)
          Else
              EndDate = DateSerial(Year(.Value & "-1"), Month(.Value & "-1") + 1, 0)
          End If
      End With
      If StartDate > EndDate Then
          MsgBox "开始日期不能大于结束日期,请重新选择!", , "提示"
          Exit Sub
      End If
      If Me.Frame1.ComboBox3 = "" Then
          Me.CommandButton3.Enabled = True
      Else
          Me.CommandButton3.Enabled = False
      End If
      Application.ScreenUpdating = False
      Sheet1.Range("A1:E" & r).AutoFilter Field:=1, Criteria1:=">=" & StartDate, Criteria2:="<=" & EndDate
      If Me.Frame1.ComboBox3 <> "" Then
          Sheet1.Range("A1:E" & r).AutoFilter Field:=3, Criteria1:=Me.Frame1.ComboBox3.Value
      End If
      With Sheet2
          .Cells.Clear
          Sheet1.AutoFilter.Range.SpecialCells(12).Copy .Cells(1, 1)
          r2 = .Range("A65536").End(xlUp).Row
          If r2 > 1 Then
              .Range("E2:E" & r2).FormulaR1C1 = "=SUM(R2C4:RC4)"
              .Range("E2:E" & r2) = .Range("E2:E" & r2).Value
          End If
      End With
      Sheet1.Range("A1:E" & r).AutoFilter
      With Me.ListView1
          .ListItems.Clear
          For i = 2 To r2
              Set Itm = .ListItems.Add()
              With Sheet2
                  Itm.Text = .Cells(i, 1)
                  Itm.SubItems(1) = .Cells(i, 2)
                  Itm.SubItems(2) = .Cells(i, 3)
                  Itm.SubItems(3) = Format(.Cells(i, 4), "0.00")
                  Itm.SubItems(4) = Format(.Cells(i, 5), "0.00")
              End With
          Next
      End With
      On Error Resume Next
      Sheet3.Range("A1:B30").Clear
      If r2 > 1 Then
          For Each rng In Sheet2.Range("C2:C" & r2)
              Col.Add rng, Key:=CStr(rng)
          Next
          For i = 1 To Col.Count
              With Sheet3
                  .Cells(i, 1) = Col(i)
                  .Cells(i, 2).FormulaR1C1 = "=SUMIF(统计数据!R2C[1]:R" & r2 & "C[1],RC[-1],统计数据!R2C[2]:R" & r2 & "C[2])"
                  .Cells(i, 2) = .Cells(i, 2).Value
                  StrResults = StrResults & Space(2) & .Cells(i, 1) & "：" & Space(3) & .Cells(i, 2) & "元" & Chr(13)
              End With
          Next
          Label4.Caption = Space(2) & StartDate & " 至：" & Chr(13) & Space(2) & EndDate & " 期间" & Chr(13) & StrResults & Space(2) & "合 计：" & Space(3) & Sheet2.Cells(r2, 5).Value & "元"
      Else
          Label4.Caption = Space(2) & StartDate & " 至：" & Chr(13) & Space(2) & EndDate & " 期间" & Chr(13) & Space(2) & Me.Frame1.ComboBox3.Value & "没有发生!"
      End If
      Application.ScreenUpdating = True
  End Sub
       窗体上的“统计”按钮的单击事件，按日期统计费用类型和金额并显示在ListView控件中。
        第12行到第18行代码取得需要统计的开始日期，如果没有选择开始日期则默认为工作表中已录入日期的第一个月的第一天。
        第19行到第25行代码取得需要统计的结束日期，如果没有选择结束日期则默认为工作表中已录入日期的最后一个月的最后一天。
        第26行到第29行代码检查开始日期和结束日期，开始日期不能大于结束日期，否则无法正确统计数据。
        第30行到第34行代码设置“图表”按钮的Enabled属性，如果没有选择“费用类别”说明统计的是全部类别，则“图表”按钮有效；如果选择了“费用类别”中的明细类别，则不需要“图表”按钮，因为单一的费用类别是不需要使用图表进行分析的。
        第36行代码对工作表中的数据进行自定义筛选，筛选出介于所选开始日期和结束日期之间的数据。
        第37行到第39行代码如果同时选择了“费用类别”中的明细类别，则对工作表中筛选出来的数据进行第二次筛选，筛选出该类别的数据。
        第40行到第48行代码将筛选结果复制到Sheet2工作表中，请参阅技巧36 。
        第49行代码取消筛选模式。
        第50行到第62行代码将Sheet2工作表中的筛选结果显示到窗体的ListView控件中。
关于ListView控件请参阅技巧131 。
        第63行到第68行代码将Sheet2工作表中的筛选结果中的C列中的明细类别使用使用Add方法去除重复值。
请参阅技巧110 。
        第69行到第80行代码在Sheet3工作表A列中写入类别明细并在B列中写入SUMIF函数计算该费用类别在统计时段中的合计发生费用，并将公式转化为数值。
最后使用标签将类别明细和费用金额显示有窗体中。
        在VBE中双击窗体上的“图表”按钮写入下面的代码。

  Private Sub CommandButton3_Click()
      Dim r As Integer
      Dim myRange As Range
      Dim myChart As ChartObject
      Application.ScreenUpdating = False
      With Sheet3
          r = .Range("A65536").End(xlUp).Row
          .ChartObjects.Delete
          Set myRange = .Range("A" & 1 & ":B" & r)
          Set myChart = .ChartObjects.Add(120, 40, 400, 250)
          With myChart.Chart
              .ChartType = xlPie
              .SetSourceData Source:=myRange, PlotBy:=xlColumns
              .Location xlLocationAsObject, "统计图表"
              .Legend.Position = -4152
              .Legend.Font.Size = 9
              .PlotArea.Interior.ColorIndex = -4142
              .PlotArea.Border.LineStyle = -4142
              .SeriesCollection(1).ApplyDataLabels _
                  AutoText:=True, _
                  HasLeaderLines:=True, _
                  ShowValue:=True, _
                  ShowCategoryName:=True, _
                  ShowPercentage:=True
              .SeriesCollection(1).DataLabels.Font.Size = 9
          End With
          Set myChart = Nothing
      End With
      Sheet1.Select
      Application.ScreenUpdating = True
      UserForm2.Show
  End Sub
       窗体中“图表”按钮的单击事件，在Sheet3工作表中根据统计数据建立图表。
        第8行代码，首先删除工作表原有的图表。
        第10行代码，在Sheet3表中建立新的图表。
        第11行到第26行代码，对新建立的图表进行格式设置。
关于图表请参阅技巧60 。
        第31行代码显示图表窗体。

步骤5，在VBE窗口中单击菜单“插入”→“用户窗体”，添加一个“图表”窗体，在窗体中添加一个Image控件和一个按钮控件，如图所示。

       在VBE中双击窗体，写入下面的代码。

  Private Sub UserForm_Initialize()
      Dim Charts As Chart
      Dim cName As String
      Set Charts = Sheet3.ChartObjects(1).Chart
      cName = ThisWorkbook.Path & "\Temp.gif"
      Charts.Export Filename:=cName, FilterName:="GIF"
      Image1.Picture = LoadPicture(cName)
  End Sub
  Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
      Kill ThisWorkbook.Path & "\Temp.gif"
  End Sub
  Private Sub CommandButton1_Click()
      Unload Me
  End Sub
       第1行到第8行代码是窗体的Initialize事件，在窗体初始化时将工作表中的图表显示在窗体中。
        第9行到第11行代码是窗体的QueryClose事件，在窗体关闭时删除临时文件。
        关于将图表显示在窗体上的方法请参阅技巧146-1。
        步骤6，为了方便使用，需要在菜单栏上添加自定义菜单，在VBE窗口中单击菜单“插入”→“模块”，在模块中写入下面的代码。

  Sub AddNewMenu()
      Dim HelpMenu As CommandBarControl
      Dim NewMenu As CommandBarPopup
      With Application.CommandBars("Worksheet menu bar")
          .Reset
          Set HelpMenu = .FindControl(ID:=.Controls("帮助(&H)").ID)
          If HelpMenu Is Nothing Then
              Set NewMenu = .Controls.Add(Type:=msoControlPopup)
          Else
              Set NewMenu = .Controls.Add(Type:=msoControlPopup, _
                  Before:=HelpMenu.Index)
          End If
          With NewMenu
              .Caption = "汽车费用(&S)"
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "批量插入空行(&D)"
                  .FaceId = 162
                  .OnAction = "InSertRows"
              End With
              With .Controls.Add(Type:=msoControlButton)
                  .Caption = "汽车费用统计(&T)"
                  .FaceId = 590
                  .OnAction = "Form"
              End With
          End With
      End With
      Set HelpMenu = Nothing
      Set NewMenu = Nothing
  End Sub

  Sub DelNewMenu()
      Application.CommandBars("Worksheet menu bar").Reset
  End Sub
  Sub Form()
      UserForm1.Show
  End Sub
  Sub InSertRows()
      Dim dInput As Byte
      Dim i As Byte
      Dim r As Integer
      r = Sheet1.Range("B65536").End(xlUp).Row
      dInput = Application.InputBox(Prompt:="请输入插入的行数：", Title:="批量插入空行", Type:=1)
      If dInput <> False Then
          Application.ScreenUpdating = False
          For i = 1 To dInput
              Sheet1.Rows(r).Insert
          Next
          Application.ScreenUpdating = True
      End If
  End Sub
       AddNewMenu过程在菜单栏的帮助菜单前添加“汽车费用”菜单。
        DelNewMenu过程删除添加的“汽车费用”菜单。
        Form过程是“汽车费用”菜单中的子菜单“汽车费用统计”所运行的宏过程，显示“图表”窗体。
        关于在工作表菜单栏中添加自定义菜单请参阅技巧80 。
 I nSertRows过程是“汽车费用”菜单中的子菜单“批量插入空行”所运行的宏过程，使用InputBox方法显示一个对话框，输入需要插入的行数后使用Insert方法在工作表中插入空行。
        关于InputBox方法请参阅技巧76 ，关于Insert方法请参阅技巧30 。
        为了在打开工作簿时自动添加菜单项，需要在工作簿的Activate事件中调用myTools过程，如下面的代码所示。

  Private Sub Workbook_Activate()
      Call AddNewMenu
  End Sub

  Private Sub Workbook_Deactivate()
      Call DelNewMenu
  End Sub
       保存关闭工作簿，重新打开工作簿，在费用明细表中录入数据后，点击“汽车费用”菜单后显示“费用统计”窗体，选择统计条件后即能统计出明细费用，如图所示。

       此时单击窗体中的“图表”按钮将用窗体显示该期间费用的图表，如图所示。

 

1

autumnalRain
楼主辛苦了，麻烦回答一个问题。
 如何删除指定文件内的所有宏代码（包括窗体、控件、模块等）？ 楼主根据技巧188-4中内容修改一下。
 谢谢！ Sub DelMacro() Dim Wb As Workbook Dim FileName As String Dim Vbc As VBComponent FileName = ThisWorkbook.Path & "\DelMacro.xls" Application.EnableEvents = False Set Wb = Workbooks.Open(FileName) For Each Vbc In Wb.VBProject.VBComponents If Vbc.Type = vbext_ct_Document Then Vbc.CodeModule.DeleteLines 1, Vbc.CodeModule.CountOfLines Else Wb.VBProject.VBComponents.Remove Vbc End If Next Wb.Close True Application.EnableEvents = True End Sub

袁版，在你的帖子：

12-3 动态的数据有效性

这节中，为何我将该段代码写入thisworkbook中就无法执行呢？你的代码是写在了sheet1中，而且多了这一行：Option Explicit。
请问这该如何解释？ 还有就是代码中的第 ...
这是用sheet1工作表事件实现的，如果要写到thisworkbook中，那是工作簿的事件，也就是Workbook_SheetChange和Workbook_SheetSelectionChange事件了，代码如下：Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Target.Column = 1 And Target.Count = 1 And Target.Row > 1 Then With Target.Validation .Delete .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:="主机,显示器" End With End If End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 Then With Target.Offset(0, 1).Validation .Delete Select Case Target Case "主机" .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:="Z286,Z386,Z486,Z586" Case "显示器" .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:="三星17,飞利浦15,三星15,飞利浦17" End Select End With End If End Sub
Option Explicit 语句强制使用变量声明。

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=37
本帖已被收录到知识树中，索引项：开发帮助和教程
还有就是代码中的第一行：Private Sub Worksheet_SelectionChange(ByVal Target As Range)，括号中的代码如何解释，在之后的代码中您在频繁的使用target这个单词，这点尤其不明白，呵呵，我自己知道这个单词是目标的意思，仅此而已，盼解答，多谢。

工作表的SelectionChange 事件，当工作表上的选定区域发生改变时产生，参数target代码新选定的区域，比如你在工作表中选择了A1单元格，target就代表A1，选择了B1到F4，target就代表B1到F4。
target返回的是一个Range对象，所以可以象使用Range对象一样使用它的各种属性，如row,column,address等。

引用: 我想问的是：Option Explicit 语句在什么情况下需要使用，多谢！
Option Explicit 语句要求在程序中强制显示声明模块中所有变量，如果使用了未声明的变量名，将出现错误提示，此句要写在所有过程之前。
Option Explicit 语句也可以不用，但是个不好的习惯，这样会大大增加出现错误的可能性及调试代码的难度。

袁版，按照您的解释，target是不是一个动态引用啊？而且不用像声明变量一样，需要事先声明。
 而这段代码——(ByVal Target As Range)，有时候系统会自动输入显示，有时候又得需要自己手工一个一个字的敲入，而 ...
应该差不多的意思吧，就是代表你当前工作表中所选择的区域。
 ByVal Target As Range 这无需输入的，VBE中双击工作表后在代码窗口选择相应的事件即可。

11部份的 Word 文档在哪下载啊
Yuan版主很久没更新了，这几天身体欠安吗？
谢谢关心，因为最近工作较忙，而且最后几个实例整理起来较慢，所以最近没有更新，正在加紧整理中。

第11部分 其他应用
技巧196 职工花名册 于 在实际工作中，往往需要一个花名册用于录入职工的各项信息，在需要时可以方便的进行查找、统计以方便日常工作。
        使用Excel制作职工花名册可以方便的录入职工信息，对所录入的信息进行修改、筛选择等，制作步骤如下： 步骤1，新建工作簿，将Sheet1工作表名称修改为“花名册”，设置成如图所示的格式。

       步骤2，在工作表的B列输入职工姓名，F列输入身份证号码，G列输入职称。
        “部门”、“职务”及“备注”从工作表中的数据有效性中选择，在VBE中双击Sheet1表，在打开的代码窗口写入下面的代码：
  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
      Dim r As Integer
      r = Sheet1.Range("B65536").End(xlUp).Row
      With Target
          If .Count = 1 And .Row > 5 And .Row <= r Then
              Sheet1.Unprotect
              Select Case .Column
              Case 8
                  With .Validation
                      .Delete
                      .Add Type:=xlValidateList, _
                          AlertStyle:=xlValidAlertStop, _
                          Operator:=xlBetween, _
                          Formula1:="经理室,办公室,行政科,生技科,财务科," _
                            & "营业部,制水车间,污水厂,其他,安装公司,退休"
                  End With
              Case 9
                  With .Validation
                      .Delete
                      .Add Type:=xlValidateList, _
                          AlertStyle:=xlValidAlertStop, _
                          Operator:=xlBetween, _
                          Formula1:="经理,副经理,支书,副支书,经理助理," _
                            & "中层正职,中层副职,总账会计,辅助会计," _
                            & "辅助会计,出纳会计,协理员,管理员,驾驶员," _
                            & "办事员,科档员,计量员,收费员,发货员," _
                            & "采购员,化验员,监察队员,班组长,拆表工," _
                            & "抄表工,勘估设计,预决算,校表工,换表工," _
                            & "机修工,电工,中控值班,制水工,安装工," _
                            & "外借,内退"
                  End With
              Case 10
                  With .Validation
                      .Delete
                      .Add Type:=xlValidateList, _
                          AlertStyle:=xlValidAlertStop, _
                          Operator:=xlBetween, _
                          Formula1:="在职,内退,退休"
                  End With
              End Select
              Sheet1.Protect
          End If
      End With
  End Sub
       工作表的SelectionChange事件过程，当选择工作表的H、I和J列时自动生成相应的数据有效性，请参阅技巧12-1。
        “性别”、“出生年月”及“年龄”由输入的身份证号码自动生成，在Sheet1表的代码窗口写入下面的代码：
  Private Sub Worksheet_Change(ByVal Target As Range)
      Sheet1.Unprotect
      With Target
          If .Count = 1 And .Row > 5 And .Column = 6 Then
              If .Text <> "" Then
                  Application.EnableEvents = False
                  .Offset(0, -5).FormulaR1C1 = "=ROW()-5"
                  .Offset(0, -3) = IIf(Mid(.Text, 17, 1) Mod 2 = 0, "女", "男")
                  .Offset(0, -2) = Format(Mid(.Text, 7, 8), "#-00-00")
                  .Offset(0, -1).FormulaR1C1 = "=DATEDIF(TEXT(MID(RC[1],7,8),""#-00-00""),TODAY(),""y"")"
                  Application.EnableEvents = True
              Else
                  Rows(.Row) = ""
              End If
          End If
      End With
      Sheet1.Protect
  End Sub
       工作表的Change事件过程，当输入职工身份证号码后在工作表的C、D和E列自动生成相应的“性别”、“出生年月”及“年龄”。
        第7行代码，在A列写入序号的公式。
        第8行代码，根据身份证号码的最后第二位数在C列中写入性别。
        第9行代码，根据身份证号码中的出生年月信息在D列中写入出生年月。
        第10行代码，根据身份证号码中的出生年月信息在E列中写入判断年龄的公式，因为年龄是动态的，所以只能写入公式。
        在工作表的H2、H3单元格中写入统计人员类别的公式。
        步骤3，为了方便使用，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：

#SORT
  Sub SectorSort()
      Dim r As Integer
      With Sheet1
          .Unprotect
          r = .Range("B65536").End(xlUp).Row
          If MsgBox("是否按公司部门顺序进行排序?", 36) = 6 Then
              .Range("A6:J" & r).Sort Key1:=.Range("H6"), _
                  Order1:=xlAscending, Key2:=Range("D6"), _
                  OrderCustom:=13
          End If
          .Protect
      End With
  End Sub
       SectorSort过程对职工花名册按部门进行排序。
        第7行到第9行代码使用Sort方法对职工花名册进行排序，应用于Range对象的Sort方法对数据透视表、单元格区域或活动区域（如果指定区域仅包含一个单元格）进行排序，语法如下：
expression.Sort(Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3) 其中Key1参数是可选的，指定第一个排序字段，本例中按部门进行排序。
        Order1参数是可选的，在Key1参数中指定的字段或区域的排序顺序。
        Key2参数是可选的，指定第二个排序字段，本例中按出生年月进行排序。
        OrderCustom参数是可选的，是从 1 开始的整数，指定了在自定义排序顺序列表中的索引号。
如果省略参数，则使用常规排序。
本例中在工作簿中添加了自定义的部门序列，索引号为13，如图所示。

  Sub AgeSort()
      Dim r As Integer
      Dim imsg As Integer
      With Sheet1
          r = .Range("B65536").End(xlUp).Row
          imsg = MsgBox("选择[是]按升降序排序,选择[否]按降序排序", 3)
          Select Case imsg
              Case 6
                  .Unprotect
                  .Range("A6:J" & r).Sort Key1:=.Range("E6"), _
                      Order1:=xlAscending, Key2:=.Range("D6")
              Case 7
                  .Unprotect
                  .Range("A6:J" & r).Sort Key1:=.Range("E6"), _
                      Order1:=xlDescending, Key2:=.Range("D6")
              End Select
          .Protect
      End With
  End Sub
       AgeSort过程对职工花名册依据年龄进行排序。
        第10、11行代码，使用Sort方法对职工花名册按年龄进行升序排序，Sort方法的Order1参数排序顺序，可为表格所示的XlSortOrder 常量之一。
               第14、15行代码，使用Sort方法对职工花名册按年龄进行降序排序。

  Sub Forshow()
      Dim r As Integer
      With Sheet1
          .Unprotect
          r = .Range("B65536").End(xlUp).Row
          .Range("A6:J" & r).Sort Key1:=.Range("H6"), _
              Order1:=xlAscending, Key2:=Range("D6"), _
              OrderCustom:=13
          .Protect
      End With
      UserForm1.Show
  End Sub
       Forshow过程对职工花名册按部门进行排序后显示按部门进行筛选的窗体。

  Sub AgeSortForshow()
      Dim r As Integer
      With Sheet1
          .Unprotect
          r = .Range("B65536").End(xlUp).Row
          .Range("A6:J" & r).Sort Key1:=.Range("E6"), _
              Order1:=xlAscending, Key2:=.Range("D6")
          .Protect
      End With
      UserForm2.Show
  End Sub
       AgeSortForshow过程对职工花名册按年龄进行排序后显示按年龄进行筛选的窗体。
        步骤4，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个列表框控件和两个按钮按件，如图 所示。
               双击窗体，在打开的代码窗口写入下面的代码：
  Private Sub UserForm_Initialize()
      On Error Resume Next
      Dim Col As New Collection
      Dim rng As Range, arr
      Dim i As Integer
      For Each rng In Sheet1.Range("H6:H" & Sheet1.Range("B65536").End(xlUp).Row)
          If Trim(rng) <> "" Then
              Col.Add rng, key:=CStr(rng)
          End If
      Next
      ReDim arr(1 To Col.Count)
      For i = 1 To Col.Count
          arr(i) = Col(i)
      Next
      With Me.ListBox1
          .List = arr
          .ListStyle = 1
          .MultiSelect = 1
      End With
  End Sub
       窗体的Initialize事件过程，窗体显示时将部门名称加载到窗体的列表框中。
        第6行到第14行代码，使用Add方法将工作表H列中的部门名称去除重复值。
        第15行到第19行代码，将部门名称加载到窗体的列表框并将列表框设置为显示多重选择列表的列表框。
窗体显示时如图所示。
               双击窗体的“筛选”按钮写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim i As Integer
      Dim r As Integer
      Dim r2 As Integer
      Sheet1.Unprotect
      Sheet2.Unprotect
      Application.ScreenUpdating = False
      r2 = Sheet2.Range("B65536").End(xlUp).Row
      If r2 > 5 Then
          With Sheet2.Range("A6:J" & r2)
              .ClearContents
              .Borders.LineStyle = xlNone
          End With
      End If
      r = Sheet1.Range("B65536").End(xlUp).Row
      For i = 0 To ListBox1.ListCount - 1
          If ListBox1.Selected(i) = True Then
              Sheet1.Range("A5:J" & r).AutoFilter Field:=8, Criteria1:="=" & ListBox1.List(i)
              With Sheet2
                  r2 = .Range("B65536").End(xlUp).Row
                  Sheet1.Range("A6:J" & r).SpecialCells(12).Copy
                  .Cells(r2 + 1, 1).PasteSpecial Paste:=xlPasteValues
                  Application.CutCopyMode = False
                  With .Range("A6:A" & .Range("B65536").End(xlUp).Row)
                      .FormulaR1C1 = "=ROW()-5"
                      .Value = .Value
                  End With
              End With
          End If
      Next
      With Sheet2
          .Range("A6:J" & .Range("B65536").End(xlUp).Row).Borders.LineStyle = xlContinuous
          Application.Goto Reference:=.Range("A2"), Scroll:=True
          .Protect
      End With
      Sheet1.Range("A1:J" & r).AutoFilter
      Sheet1.Protect
      Unload Me
      Application.ScreenUpdating = True
  End Sub
       “筛选”按钮的单击过程，将窗体列表框中所选中的部门数据筛选后复制到工作表中。
        第10行到第12行代码，删除工作表中原有的数据，去除边框线。
        第16行到第29行代码，将窗体列表框中所选中的部门数据进行筛选后依次复制到工作表中。
        其中第18行代码使用AutoFilter方法进行筛选。
应用于Range对象的AutoFilter方法使用“自动筛选”筛选出一个列表，语法如下：
expression.AutoFilter(Field, Criteria1, Operator, Criteria2, VisibleDropDown) 参数Field是可选的，相对于作为筛选基准字段（从列表左侧开始，最左侧的字段为第一个字段）的偏移量。
本例中设置为8，即指定工作表中的H列进行筛选。
        参数Criteria1是可选的，筛选条件。
本例中设置为窗体列表框中所选中的部门名称。
        第32行代码，将筛选后的数据画上边框线。
        步骤5，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件和两个组合框按件，如图 所示。
               双击窗体，在打开的代码窗口写入下面的代码：
  Private Sub UserForm_Initialize()
      On Error Resume Next
      Dim Col As New Collection
      Dim rng As Range, arr
      Dim i As Integer
      For Each rng In Sheet1.Range("E6:E" & Sheet1.Range("B65536").End(xlUp).Row)
          Col.Add rng, key:=CStr(rng)
      Next
      ReDim arr(1 To Col.Count)
      For i = 1 To Col.Count
          arr(i) = Col(i)
      Next
      Me.ComboBox1.List = arr
      Me.ComboBox2.List = arr
  End Sub
       窗体的Initialize事件过程，窗体显示时将所有的年龄加载到窗体的组合框中。
        第6行到第12行代码，使用Add方法将工作表E列中的年龄去除重复值。
        第13、14行代码，将年龄加载到窗体的组合框中。
        双击窗体的“筛选”按钮写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim r As Integer
      Dim r2 As Integer
      Dim dInput As Double
      If Me.ComboBox1.Value = "" Or Me.ComboBox2.Value = "" Then
          MsgBox "请选择需要筛选的年龄!"
          Exit Sub
      End If
      If Me.ComboBox1.Value > Me.ComboBox2.Value Then
          MsgBox "开始年龄不能等结束年龄,请重新选择!"
          Me.ComboBox1.ListIndex = -1
          Me.ComboBox2.ListIndex = -1
          Exit Sub
      End If
      Application.ScreenUpdating = False
      With Sheet1
          r = .Range("B65536").End(xlUp).Row
          .Unprotect
          .Range("A5:J" & r).AutoFilter Field:=5, Criteria1:=">=" & Me.ComboBox1.Value, Operator:=xlAnd, Criteria2:="<=" & Me.ComboBox2.Value
          With Sheet2
              .Unprotect
              r2 = .Range("B65536").End(xlUp).Row
              If r2 > 5 Then
                  With .Range("A6:J" & r2)
                      .ClearContents
                      .Borders.LineStyle = xlNone
                  End With
              End If
              Sheet1.Range("A6:J" & r).SpecialCells(12).Copy
              .Cells(6, 1).PasteSpecial Paste:=xlPasteValues
              Application.CutCopyMode = False
              With .Range("A6:A" & .Range("B65536").End(xlUp).Row)
                  .FormulaR1C1 = "=ROW()-5"
                  .Value = .Value
              End With
                  .Range("A6:J" & .Range("B65536").End(xlUp).Row).Borders.LineStyle = xlContinuous
              Unload Me
              Application.Goto Reference:=.Range("A3"), Scroll:=True
              .Protect
          End With
          .Range("A1:J" & r).AutoFilter
          .Protect
      End With
      Application.ScreenUpdating = True
  End Sub
       “筛选”按钮的单击过程，将根据窗体组合框中所选中的年龄进行筛选后的数据复制到工作表中。
        第5行到第8行代码，年龄不能为空。
        第9行到第14行代码，开始年龄不能小于结束年龄。
        第19行代码，使用AutoFilter方法进行筛选。
将第一个筛选条件设置为开始年龄，第二个筛选条件设置为结束年龄。
        第23行到第28行代码，删除工作表中原有的数据，去除边框线。
        第29行到第35行代码，将筛选后的数据复制到工作表中。
        第36行代码，将筛选后的数据画上边框线。
        步骤6，为了方便使用，在工作表中单击菜单“视图”→“工具栏”→“窗体”，添加两个框架，在每个框架中添加两个单选框，将模块中的宏指定给单选框，如图所示。

       步骤7，为了保存筛选后的数据，将工作簿的Sheet2表重命名为“筛选数据”，并设置成如图所示的格式。

       步骤8，选择“花名册”表的B、F和G列第6行以下区域，去除其锁定属性后保护工作表，对“筛选数据”表进行保护。
在工作表中单击菜单“工具”→“选项”，在显示的选项对话框的视图页中去除工作表的行号列标及网格线后保存关闭工作簿。
 打开工作簿，在“花名册”表中输入职工姓名、身份证号及职称后“花名册”表如图所示。

       对表中数据进行筛选，比如按部门中的“生技科”进行筛选后“筛选数据”表中如图所示。

第11部分 其他应用
技巧197 收据系统 开具收据是财务工作中的一项经常性的工作，如果需要开具大量收据，采用手工方法开具收据时不仅繁琐而且极易出错，此时除了使用专业软件，还可以使用VBA制作的收据填写、打印系统，简化日常工作，减轻劳动强度。
        步骤1，新建工作簿，将Sheet2工作表名称重命名为“维护”，设置成如图所示的格式，用来保存收据系统使用过程中必需的信息。

       步骤2，因为收据系统是财务方面的系统，在使用时需要相应的权限，需要使用密码登陆，所以需要一个系统登陆窗体。
        在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加三个标签控件、一个文本框控件、一个组合框和两个按钮按件，在窗体的属性窗口将其Picture属性设置为合适的图片并调整好控件的大小与位置，如图所示。
               双击登陆窗体，在打开的代码窗口写入下面的代码：
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  Private Const GWL_STYLE = (-16)
  Private Const WS_SYSMENU = &H80000
  Private hwnd As Long
  Private Sub UserForm_Initialize()
      Dim Istype As Long
      Dim r As Integer
      Dim i As Integer
      hwnd = FindWindow("ThunderDFrame", Me.Caption)
      Istype = GetWindowLong(hwnd, GWL_STYLE)
      Istype = Istype And Not WS_SYSMENU
      SetWindowLong hwnd, GWL_STYLE, Istype
      DrawMenuBar hwnd
      r = Sheet2.Range("A65536").End(xlUp).Row
      For i = 2 To r
          Me.ComboBox1.AddItem Sheet2.Cells(i, 1).Value
      Next
      Me.Label3.Caption = Sheet2.Cells(2, 4) & "收据系统"
  End Sub

代码解析： 登陆窗体的Initialize事件过程，窗体显示时使用API函数去除窗体的关闭按钮，组合框控件显示所有的用户名。
        第1行到第7行代码，API函数声明。
        第12行到第16行代码，去除窗体的关闭按钮。
请参阅技巧138 。
        第18行到第20行代码，组合框控件显示所有的用户名供用户选择。
        第21行代码，窗体标签显示使用单位的名称。
        双击窗体上的“登陆”按钮，写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim r As Integer
      Dim rng As Range
      If ComboBox1.Value = "" Then
          MsgBox "请选择用户!", 64, "提示"
          Exit Sub
      End If
      With Sheet2
          r = .Range("A65536").End(xlUp).Row
          With .Range("A2:A" & r)
              Set rng = .Find(What:=ComboBox1, _
                  After:=.Cells(.Cells.Count), _
                  LookIn:=xlValues, _
                  LookAt:=xlWhole, _
                  SearchOrder:=xlByRows, _
                  SearchDirection:=xlNext, _
                  MatchCase:=False)
              If Not rng Is Nothing And rng.Offset(0, 1) = TextBox1 Then
                  Sheet2.Range("C2:C" & r).ClearContents
                  rng.Offset(0, 2) = "√"
                  Unload Me
                  主界面.Show
              Else
                  MsgBox "对不起,密码不正确,你无权进入!", 64, "提示"
                  TextBox1 = ""
                  TextBox1.SetFocus
              End If
          End With
      End With
  End Sub
       “登陆”按钮的单击事件过程，在用户选择用户名和输入正确密码后显示“主界面”操作窗体。
        第4行到第7行代码，判断是否选择了用户名。
第一次使用时默认的用户名为“系统管理员”，登陆后可以自行添加其他用户。
        第10行到第17行代码，根据所选择的用户名在“维护”工作表的A列中查找对应的用户名所在的单元格。
        第18行到第27行代码，找到后判断该用户名的密码是否与文本框中输入的密码一致。
如果一致则关闭登陆窗体显示“主界面”操作窗体，否则提示用户密码错误。
        双击窗体上的“取消”按钮，写入下面的代码：
  Private Sub CommandButton2_Click()
      Unload Me
      ThisWorkbook.Saved = True
      Application.Quit
  End Sub
       “取消”按钮的单击事件过程，在用户选择取消后退出程序。
        双击窗体上的组合框控件，写入下面的代码：
  Private Sub ComboBox1_Change()
      TextBox1.SetFocus
  End Sub
       组合框控件的Change事件过程，在用户选择用户名后将焦点移到文本框中方便用户输入密码。

第11部分 其他应用
技巧197 收据系统 步骤3，将Sheet3工作表名称重命名为“存档”，设置成如图所示的格式，用来保存已填写收据的数据。

       步骤4，“存档”表只是用来保存已开具收据的数据，而收据系统的日常操作都在“主界面”窗体中进行，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个多页（MultiPage）控件和一个状态栏（StatusBar）控件。
在MultiPage控件的Page1页上添加一个Image控件和三个标签控件，在第一个标签的属性窗口中将其BackStyle属性设置为0，使标签背景为透明，在其他两个标签的Caption属性中写上版本信息及作者和邮箱，在Image控件的属性窗口将其Picture属性设置为合适的图片并调整好控件的大小与位置。

       双击主界面窗体，在打开的代码窗口写入下面的代码：
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
  Private Declare Function CreateMenu Lib "user32" () As Long
  Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
  Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
  Private Declare Function CreatePopupMenu Lib "user32" () As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Const GWL_WNDPROC = (-4)
  Private Const MF_STRING = &H0&
  Private Const MF_POPUP = &H10&
  Private Const MF_SEPARATOR = &H800&
  Dim MenuWnd As Long, Dump As Long, PopupMenuID As Long, PopupMenuWnd As Long, MenuID As Long
  Private Sub UserForm_Initialize()
      Dim i As Integer
      Dim str As String
      Dim arr As Variant
      If Val(Application.Version) < 9 Then
          hwnd = FindWindow("ThunderXFrame", Me.Caption)
      Else
          hwnd = FindWindow("ThunderDFrame", Me.Caption)
      End If
      MenuWnd = CreateMenu()
      PopupMenuID = CreatePopupMenu()
      Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "系统(&S)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 100, "单位设置(&C)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 101, "用户设置(&U)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 102, "切换用户(&S)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 103, "密码修改(&P)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 104, "打开Excel(&O)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 105, "退出系统(&Q)")
      PopupMenuID = CreatePopupMenu()
      Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "编辑(&E)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 110, "收款人(&R)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 111, "交款人(&P)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 112, "交款单位(&U)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 113, "常用事由(&S)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 114, "常用备注(&R)")
      PopupMenuID = CreatePopupMenu()
      Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "操作(&O)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 120, "增加(&I)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 121, "查询(&Q)")
      PopupMenuID = CreatePopupMenu()
      Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "帮助(&H)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 130, "帮助(&H)")
      Dump = AppendMenu(PopupMenuID, MF_STRING, 131, "关于(&R)")
      Dump = SetMenu(hwnd, MenuWnd)
      PreWinProc = GetWindowLong(hwnd, GWL_WNDPROC)
      SetWindowLong hwnd, GWL_WNDPROC, AddressOf MsgProcess
      Me.MultiPage1.Value = 0
      For i = 2 To Sheet2.Range("A65536").End(xlUp).Row
          If Sheet2.Cells(i, 3) = "√" Then
              str = Sheet2.Cells(i, 1)
          End If
      Next
      arr = Array(168, 100, 100, 80)
      With Me.StatusBar1
          For i = 1 To 4
              .Panels.Add(i, , "").Style = 0
              .Panels(i).Width = arr(i - 1)
          Next
          .Panels(1).Text = Sheet2.Cells(2, 4) & "收据系统"
          .Panels(2).Text = "当前用户：" & str
          .Panels(3).Text = "今天是" & Format(Date, "yyyy年m月d日")
          .Panels(4).Text = Time
      End With
      Me.Caption = Sheet2.Cells(2, 4) & "收据系统"
      Me.Label12.Caption = Sheet2.Cells(2, 4) & "收据系统"
  End Sub
  Private Sub UserForm_Terminate()
      DestroyMenu MenuWnd
      DestroyMenu PopupMenuID
      DestroyMenu PopupMenuWnd
      SetWindowLong hwnd, GWL_WNDPROC, PreWinProc
  End Sub
       主界面窗体的Initialize事件过程，窗体显示时使用API函数添加菜单及状态栏信息。
        第1行到第13行代码，API函数声明。
        第18行到第49行代码，使用API函数添加菜单。
请参阅技巧148 。
        第50行代码，窗体显示时选择MultiPage控件的第一页。
        第51行到第55行代码，将当前用户名赋给字符串变量str。
        第56行到第66行代码，在状态栏控件中添加四个窗格及显示的信息。
请参阅技巧152 。
        第67、67行代码，设置主界面窗体的标题栏及标签显示的内容。
        步骤5，为了使用主界面窗体中添加的菜单，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：
  Public PreWinProc As Long, hwnd As Long
  Public Declare Function CheckMenuRadioItem Lib "user32" (ByVal hMenu As Long, ByVal un1 As Long, ByVal un2 As Long, ByVal un3 As Long, ByVal un4 As Long) As Long
  Public Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
  Public Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
  Public Const MF_UNCHECKED = &H0&
  Public Const MF_CHECKED = &H8&
  Public Const MF_DISABLED = &H2&
  Public Const MF_GRAYED = &H1&
  Public Const MF_ENABLED = &H0&
  Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
  Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
  Private Const MF_BYCOMMAND = &H0&
  Public Function MsgProcess(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
      Dim SubMenu_hWnd As Long
      Select Case wParam
          Case 100
              If Sheet2.Cells(2, 3) <> "√" Then
                  MsgBox "请使用系统管理员登陆系统!", 64, "提示"
              Else
                  设置使用单位.Show
              End If
          Case 101
              If Sheet2.Cells(2, 3) <> "√" Then
                  MsgBox "请使用系统管理员登陆系统!", 64, "提示"
              Else
                  用户设置.Show
              End If
          Case 102
              Unload 主界面
              登陆.Show
          Case 103
              修改密码.Show
          Case 104
              If Sheet2.Cells(2, 3) <> "√" Then
                  MsgBox "请使用系统管理员登陆系统!", 64, "提示"
              Else
                  Unload 主界面
                  Application.Visible = True
              End If
          Case 105
              If MsgBox("确定要退出收据系统吗?", 64 + vbYesNo, "提示") = vbYes Then
                  Unload 主界面
                  ThisWorkbook.Save
                  Application.Quit
              End If
          Case 110
              主界面.MultiPage1.Value = 0
              编辑收款人.Show
          Case 111
              主界面.MultiPage1.Value = 0
              编辑交款人.Show
          Case 112
              主界面.MultiPage1.Value = 0
              设置交款单位.Show
          Case 113
              主界面.MultiPage1.Value = 0
              编辑常用事由.Show
          Case 114
              主界面.MultiPage1.Value = 0
              编辑常用备注.Show
          Case 120
              主界面.MultiPage1.Value = 1
          Case 121
              主界面.MultiPage1.Value = 2
          Case 130
              帮助.Show
          Case 131
              关于.Show
          Case Else
              MsgProcess = CallWindowProc(PreWinProc, hwnd, Msg, wParam, lParam)
      End Select
  End Function
       根据主界面窗体中添加菜单的ID设置其各项功能。
        第1行到第13行代码，API函数声明。
        第17行到第22行代码，“系统”菜单中的“单位设置”菜单功能，显示“设置使用单位”窗体设置收据系统的使用单位名称。
其中第18、19行代码判断当前用户是否是系统管理员，只有系统管理员才能设置收据系统的使用单位名称。
设置单位名称需使用“设置使用单位”窗体，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件、一个文本框控件及两个按钮按件，如图所示。
               双击窗体中的“确定”按钮，写入下面的代码：
  Private Sub CommandButton1_Click()
      If Sheet2.Cells(2, 4) <> "" Then
          If MsgBox("是否重新设置单位名称？", 36, "提示") = vbNo Then
              Unload Me
              Exit Sub
          End If
      End If
      If Trim(Me.Frame1.TextBox1.Value) = "" Then
          MsgBox "单位名称不能为空!", 64, "提示"
          Me.Frame1.TextBox1.SetFocus
          Exit Sub
      End If
      Sheet2.Cells(2, 4) = Trim(Me.Frame1.TextBox1.Value)
      主界面.Caption = Sheet2.Cells(2, 4) & "收据系统"
      主界面.Label12.Caption = Sheet2.Cells(2, 4) & "收据系统"
      主界面.StatusBar1.Panels(1).Text = Sheet2.Cells(2, 4) & "收据系统"
      Unload Me
  End Sub
       第23行到第28行代码，“系统”菜单中的“用户设置”菜单功能，显示“用户设置”窗体设置收据系统的用户名称。
其中第24、25行代码判断当前用户是否是系统管理员，只有系统管理员才能设置收据系统的用户名称。
设置用户名称需使用“用户设置”窗体，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加两个框架控件、一个列表框控件、一个文本框控件及三个按钮按件，如图所示。
               双击“用户设置”窗体写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim r As Integer
      Dim i As Integer
      r = Sheet2.Range("A65536").End(xlUp).Row
      For i = 3 To r
          Me.Frame1.ListBox1.AddItem Sheet2.Cells(i, 1).Value
      Next
      Me.Frame2.TextBox1.SetFocus
  End Sub
  Private Sub CommandButton1_Click()
      Dim r As Integer
      Dim rng As Range
      If Me.Frame1.ListBox1.ListIndex < 0 Then
          MsgBox "请选择需删除的用户姓名!", 64, "提示"
          Exit Sub
      End If
      r = Sheet2.Range("A65536").End(xlUp).Row
      With Sheet2.Range("A3:F" & r)
          Set rng = .Find(What:=Me.Frame1.ListBox1.Value, _
              After:=.Cells(.Cells.Count), _
              LookIn:=xlValues, _
              LookAt:=xlWhole, _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlNext, _
              MatchCase:=False)
          If Not rng Is Nothing Then
              rng.Offset(0, 1).Delete Shift:=xlUp
              rng.Delete Shift:=xlUp
              Me.Frame1.ListBox1.RemoveItem (ListBox1.ListIndex)
              MsgBox "已经成功删除!", 64, "提示"
          End If
      End With
  End Sub
  Private Sub CommandButton2_Click()
      Dim r As Integer
      With Me.Frame2.TextBox1
          r = Sheet2.Range("A65536").End(xlUp).Row
          If Trim(.Value) = "" Then
              MsgBox "用户姓名不能为空!", 64, "提示"
              .SetFocus
              Exit Sub
          End If
          If WorksheetFunction.CountIf(Sheet2.Range("A3:A" & r), Trim(.Text)) > 0 Then
              MsgBox "用户已经存在!", 64, "提示"
              .Value = ""
              Exit Sub
          End If
          Sheet2.Range("A" & r + 1) = Trim(.Text)
          Me.Frame1.ListBox1.AddItem Trim(.Text)
          .Value = ""
          .SetFocus
      End With
      MsgBox "用户成功增加!", 64, "提示"
  End Sub
  Private Sub CommandButton3_Click()
      Unload Me
  End Sub
       第29行到第31行代码，“系统”菜单中的“切换用户”菜单功能，关闭主界面窗体，显示系统登陆窗体。
        第32、33行代码，“系统”菜单中的“密码修改”菜单功能，显示“密码修改”窗体重新设置当前用户的密码，设置用户密码需使用“密码修改”窗体，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件、三个文本框控件及两个按钮按件，如图所示。
               双击“密码修改”窗体写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim r As Integer
      Dim i As Integer
      Dim p As Integer
      Dim Password As String
      With Sheet2
          r = .Range("A65536").End(xlUp).Row
          For i = 2 To r
              If .Cells(i, 3) = "√" Then
                  Password = .Cells(i, 2).Text
                  p = i
                  Exit For
              End If
          Next
          If Me.TextBox1.Text <> Password Then
              MsgBox "对不起,密码不正确,你无权修改!", 64, "提示"
              Me.TextBox1 = ""
              Me.TextBox1.SetFocus
              Exit Sub
          End If
          If Me.TextBox2.Text <> Me.TextBox3.Text Then
              MsgBox "确认密码不一致,请重新输入!", 64, "提示"
              Me.TextBox3 = ""
              Me.TextBox3.SetFocus
              Exit Sub
          End If
          .Cells(p, 2) = Me.TextBox3.Text
      End With
      Unload Me
  End Sub
       第34行到第40行代码，“系统”菜单中的“打开Excel”菜单功能，收据系统日常使用时只能在主界面窗体中操作，只有系统管理员才能打开工作表对其进行修改。
        第41行到第46行代码，“系统”菜单中的“退出系统”菜单功能，关闭Excel程序。
        第47行第61行代码，“编辑”菜单的各项功能，对使用收据系统所需要的一些信息进行添加和删除。
其中第47、48行代码显示“编辑收款人”窗体对常用收款人进行编辑，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加两个框架控件、一个列表框控件、一个文本框控件及三个按钮按件，如图所示。
               其他窗体与“编辑收款人”窗体类似，窗体中的代码请参考“用户设置”窗体中的代码。
        第62、63行代码，“操作”菜单中的“增加”菜单功能，选择主界面窗体中多页控件的Page2页，可以填写、打印收据。
        第64、65行代码，“操作”菜单中的“查询”菜单功能，选择主界面窗体中多页控件的Page3页，可以对已填写收据进行查询、打印。
        第66、67行代码，“帮助”菜单中的“关于”菜单功能，显示“关于”窗体。
        第68、69行代码，“帮助”菜单中的“帮助”菜单功能，显示“帮助”窗体。

第11部分 其他应用
技巧197 收据系统 步骤6，在VBE窗口中选择“主界面”窗体的Page2页，在Page2页中添加四个按钮控件、一个框架控件，框架控件中添加六个文本框控件、四个组合框控件及相应的标签和一个DTP控件，如图所示。

       双击窗体上的“新增”按钮，写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim r As Integer
      Dim i As Integer
      Dim Number As String
      With Sheet2
          If .Range("D2") = "" Then
              MsgBox "请先设置使用单位!", 64, "提示"
              Exit Sub
          End If
          MultiPage1.Page2.TextBox2 = .Range("D2")
          If .Cells(2, 3) = "√" Then
              MsgBox "请以用户身份登陆!", 64, "提示"
              Exit Sub
          End If
          r = .Range("A65536").End(xlUp).Row
          For i = 3 To r
              If .Cells(i, 3) = "√" Then
                  MultiPage1.Page2.TextBox5 = .Cells(i, 1)
              End If
          Next
      End With
      With Sheet3
          r = .Range("A65536").End(xlUp).Row
          If .Range("A2") = "" Then
              Number = Year(DTPicker1.Value) & Format(1, "0000")
          End If
          If Val(Year(DTPicker1.Value)) > Val(Left(.Range("A" & r).Value, 4)) Then
              Number = Year(DTPicker1.Value) & Format(1, "0000")
          Else
              Number = Format(.Range("A" & r).Value + 1, "00000000")
          End If
      End With
      With MultiPage1.Page2
          .ComboBox1.Value = ""
          .ComboBox2.Value = ""
          .ComboBox3.Value = ""
          .ComboBox4.Value = ""
          .TextBox1.Value = Number
          .TextBox3.Value = ""
          .TextBox4.Value = ""
          .TextBox6.Value = ""
      End With
  End Sub
       “新增”按钮的单击过程，将收据号码、使用单位及用户名称显示在文本框中。
        第6行到第9行代码，判断收据系统是否已设置使用单位。
        第10行代码，将工作表中已设置好的单位名称显示在“收款单位名称”文本框中。
        第11行到第14行代码，判断当前用户是否是系统管理员，系统管理员不能进行新增收据的操作。
        第15行到第20行代码，将当前用户的名称显示在“签发人”文本框中。
        第23行到第26行代码，判断收据系统是否第一次使用。
如果是第一次使用，新增收据号码为当前年份加0001。
        第27、28行代码，判断收据系统是否是跨年度使用。
如果是跨年度使用，新增收据号码为当前年份加0001。
        第30行代码，如果收据系统是本年度中正常使用且已开具过收据，新增收据号码为最后所开具的收据号码加一。
        第33行到第42行代码，将收据号码显示在“收据号码”文本框中并清除其他内容。
        填写完毕的收据需保存到工作表中，将Sheet3工作表重命名为“存档”表并设置成如图所示的格式用来保存已开具收据的各项内容。

       双击窗体上的“保存”按钮，写入下面的代码：
  Private Sub CommandButton2_Click()
      Dim r As Integer
      r = Sheet3.Range("A65536").End(xlUp).Row
      If MultiPage1.Page2.TextBox1 = "" Then
          MsgBox "没有可保存的收据,请选择新增按钮!", 64, "提示"
          Exit Sub
      End If
      If WorksheetFunction.CountIf(Sheet3.Range("A2:A" & r), Trim(MultiPage1.Page2.TextBox1.Text)) > 0 Then
          MsgBox "收据已经保存!", 64, "提示"
          Exit Sub
      End If
      If If Sheet3.Range("A2") <> "" And MultiPage1.Page2.DTPicker1.Value < Sheet3.Cells(r, 2) Then
          MsgBox "日期错误，请重新选择日期!", 64, "提示"
          Exit Sub
      End If
      If MultiPage1.Page2.ComboBox4.Value = "" Then
          MsgBox "请填写交款事由!", 64, "提示"
          MultiPage1.Page2.ComboBox4.SetFocus
          Exit Sub
      End If
      If MultiPage1.Page2.ComboBox1.Value = "" Then
          MsgBox "请填写交款单位!", 64, "提示"
          MultiPage1.Page2.ComboBox1.SetFocus
          Exit Sub
      End If
      If MultiPage1.Page2.ComboBox2.Value = "" Then
          MsgBox "请填写收款人姓名!", 64, "提示"
          MultiPage1.Page2.ComboBox2.SetFocus
          Exit Sub
      End If
      If MultiPage1.Page2.ComboBox3.Value = "" Then
          MsgBox "请填写交款人姓名!", 64, "提示"
          MultiPage1.Page2.ComboBox3.SetFocus
          Exit Sub
      End If
      If MultiPage1.Page2.TextBox4.Value = "" Then
          MsgBox "请填写收款金额!", 64, "提示"
          MultiPage1.Page2.TextBox4.SetFocus
          Exit Sub
      End If
      If MultiPage1.Page2.TextBox6.Value = "" Then
          MsgBox "请填写备注!", 64, "提示"
          MultiPage1.Page2.TextBox6.SetFocus
          Exit Sub
      End If
      With Sheet3
          .Cells(r + 1, 1) = MultiPage1.Page2.TextBox1.Value
          .Cells(r + 1, 2) = MultiPage1.Page2.DTPicker1.Value
          .Cells(r + 1, 3) = MultiPage1.Page2.ComboBox4.Value
          .Cells(r + 1, 4) = MultiPage1.Page2.ComboBox1.Value
          .Cells(r + 1, 5) = MultiPage1.Page2.ComboBox3.Value
          .Cells(r + 1, 6) = MultiPage1.Page2.TextBox2.Value
          .Cells(r + 1, 7) = MultiPage1.Page2.ComboBox2.Value
          .Cells(r + 1, 8) = MultiPage1.Page2.TextBox3.Value
          .Cells(r + 1, 9) = MultiPage1.Page2.TextBox4.Value
          .Cells(r + 1, 10) = MultiPage1.Page2.TextBox6.Value
          .Cells(r + 1, 11) = MultiPage1.Page2.TextBox2.Value
          .Cells(r + 1, 12) = MultiPage1.Page2.TextBox5.Value
      End With
      Sheet4.Range("K1") = MultiPage1.Page2.TextBox1.Value
      MsgBox "收据已保存，请打印!", 64, "提示"
  End Sub
       “保存”按钮的单击过程，将填写完整的收据内容保存到“存档”表中。
        第4行到第7行代码，判断是否已选择“新增”按钮。
因为“收据号码”文本框中的号码是不能通过手工输入的，只能选择“新增”按钮由系统输入。
        第8行到第11行代码，判断收据号码与“存档”表中保存的收据号码是否重复，使同一收据不能重复保存。
        第12行到第15行代码，判断收据日期是否大于等于“存档”表中保存的最后一张收据的日期，使收据只能按日期顺序开具。
        第16行到第45行代码，判断收据内容是否填写完整。
        第46行到第59行代码，将收据内容保存到“存档”表的最后一行。
        第60行代码，将所开收据的号码写入到“打印”表的K1单元格。
        收据保存后需要打印，将Sheet4工作表重命名为“打印”表。
因为笔者所在单位不使用针式打印机，不能进行套打，所以将“打印”表设置成如图所示的格式，使用激光打印机打印。
如果需要进行套打，只需按所需要打印收据的页面重新进行设置即可。

       “打印”表中的单元格写入VLOOKUP函数，根据K1单元格中的号码在“存档”表中查找相应的数据显示在各单元格中。
        双击窗体上的“打印”按钮，写入下面的代码：
  Private Sub CommandButton3_Click()
      Dim r As Integer
      Dim rng As Range
      With Sheet3
          r = .Range("A65536").End(xlUp).Row
          If MultiPage1.Page2.TextBox1.Value = "" Then
              MsgBox "没有可打印的收据!", 64, "提示"
              Exit Sub
          End If
          If WorksheetFunction.CountIf(.Range("A2:A" & r), Trim(MultiPage1.Page2.TextBox1.Text)) = 0 Then
              MsgBox "请保存后再打印!", 64, "提示"
              Exit Sub
          End If
          With .Range("A2:A" & r)
              Set rng = .Find(What:=MultiPage1.Page2.TextBox1.Value, _
                  After:=.Cells(.Cells.Count), _
                  LookIn:=xlValues, _
                  LookAt:=xlWhole, _
                  SearchOrder:=xlByRows, _
                  SearchDirection:=xlNext, _
                  MatchCase:=False)
              If Not rng Is Nothing Then
                  If rng.Offset(0, 12).Text = "√" Then
                      MsgBox "已经打印的收据不可再打印!", 64, "提示"
                      Exit Sub
                  End If
              End If
          End With
          .Range("M" & r).Value = "√"
      End With
      Sheet4.Range("K1") = MultiPage1.Page2.TextBox1.Value
      Sheet4.PrintOut
  End Sub
       “打印”按钮的单击过程，打印收据。
        第6行到第9行代码，判断是否有需要打印的收据。
        第10行到第13行代码，判断当前收据是否已经保存。
        第14行到第28行代码，判断当前收据是否已经打印。
已经打印过的收据在“存档”表的M列中会写上已打印标识“√”。
        第29行代码，在“存档”表的该收据内容所在的M列中写上已打印标识“√”。
        第31、32行代码，将收据号码写入到“打印”表的K1单元格，打印该收据。
        双击窗体上的“取消”按钮，写入下面的代码：
  Private Sub CommandButton4_Click()
      With MultiPage1.Page2
          .ComboBox1.Value = ""
          .ComboBox2.Value = ""
          .ComboBox3.Value = ""
          .ComboBox4.Value = ""
          .TextBox1.Value = ""
          .TextBox3.Value = ""
          .TextBox4.Value = ""
          .TextBox6.Value = ""
      End With
      主界面.MultiPage1.Value = 0
  End Sub
       “取消”按钮的单击过程，清除数据并返回主界面的Page1页面。
        为了方便收据的填写，在开具收据时，日期由DTP控件选择，事由、单位名称、收款人及交款人可以手工输入，也可以从窗体中的组合框中选择已有的信息。
双击MultiPage1控件写入下面的代码：
  Private Sub MultiPage1_Change()
      Dim i As Integer
      Dim c As Integer
      Select Case MultiPage1.Value
          Case 1
              For c = 1 To 4
                  MultiPage1.Page2.Controls("ComboBox" & c).Clear
                  For i = 2 To Sheet2.Cells(65536, c + 4).End(xlUp).Row
                      MultiPage1.Page2.Controls("ComboBox" & c).AddItem Sheet2.Cells(i, c + 4).Value
0 Next
              Next
              MultiPage1.Page2.DTPicker1 = Date
          Case 2
              With MultiPage1.Page3.ListView1
                  .ListItems.Clear
                  .ColumnHeaders.Add , , Space(3) & "号码", 54, 0
                  .ColumnHeaders.Add , , Space(3) & "日期", 54, 0
                  .ColumnHeaders.Add , , Space(12) & "事由", 130, 0
                  .ColumnHeaders.Add , , Space(6) & "交款单位", 100, 0
                  .ColumnHeaders.Add , , "交款人", 40, 0
                  .ColumnHeaders.Add , , Space(6) & "收款单位", 90, 0
                  .ColumnHeaders.Add , , "收款人", 40, 0
                  .ColumnHeaders.Add , , Space(10) & "金额大写", 130, 0
                  .ColumnHeaders.Add , , "金额小写", 50, 1
                  .ColumnHeaders.Add , , Space(14) & "备注", 150, 0
                  .ColumnHeaders.Add , , Space(5) & "填发单位", 84, 0
                  .ColumnHeaders.Add , , "签发人", 40, 0
                  .View = lvwReport
                  .Gridlines = True
                  .FullRowSelect = True
              End With
      End Select
  End Sub
       MultiPage控件的Change事件过程。
        第6行到第12行代码，当选择MultiPage控件的Page2页面即新增收据时，将“维护”表中所保存的信息加载到组合框中，并将DTP控件的日期设置为当前日期。
        第13行到第31行代码，当选择MultiPage控件的Page3页面即查询收据时，为Page3页中的ListView控件添加列标题。
请参阅技巧131 。

第11部分 其他应用
技巧197 收据系统 为了将输入的小写金额转换为人民币大写金额，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：
  Public Function RMBDX(M)
      On Error Resume Next
      RMBDX = Replace(Application.Text(Round(M + 0.00000001, 2), "[DBnum2]"), ".", "元")
      RMBDX = IIf(Left(Right(RMBDX, 3), 1) = "元", Left(RMBDX, Len(RMBDX) - 1) & "角" & Right(RMBDX, 1) & "分", IIf(Left(Right(RMBDX, 2), 1) = "元", RMBDX & "角整", IIf(RMBDX = "零", "", RMBDX & "元整")))
      RMBDX = Replace(Replace(Replace(Replace(RMBDX, "零元零角", ""), "零元", ""), "零角", "零"), "-", "负")
  End Function
       自定义RMBDX函数，将小写金额转换为人民币大写金额，请参阅技巧163 。
        双击小写金额文本框，写入下面的代码：
  Private Sub TextBox4_Change()
      If Not IsNumeric(TextBox4.Text) And TextBox4.Text <> "" Then
          MsgBox "请输入正确的小写金额!", 64, "提示"
          Exit Sub
      End If
      MultiPage1.Page2.TextBox3 = RMBDX(MultiPage1.Page2.TextBox4.Value)
  End Sub
  Private Sub TextBox4_AfterUpdate()
      Me.TextBox4.Value = Format(TextBox4.Value, "0.00")
  End Sub
       第1行到第6行代码，文本框的Change事件过程，将小写文本框中输入的正确的小写金额转换为人民币大写金额写入到大写文本框中。
        第8行到第10行代码，文本框的AfterUpdate事件过程，将小写金额格式化为两位小数格式。
        备注可以手工输入，也可以从窗体中选择已有的信息。
在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个MultiPage控件和两个按钮按件，在MultiPage控件的Page1页中添加一个框架控件，在框架控件中添加六个文本框控件、六个标签控件，如图所示。
               在MultiPage控件的Page2页中添加一个框架控件，在框架控件中添加两个文本框控件和两个标签控件，如图所示。
               在MultiPage控件的Page3页中添加一个框架控件，在框架控件中添加一个列表框控件，如图所示。
               双击“输入常用备注”窗体，写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim r As Integer
      Dim i As Integer
      MultiPage1.Value = 0
      r = Sheet2.Range("I65536").End(xlUp).Row
      For i = 2 To r
          MultiPage1.Page3.ListBox1.AddItem Sheet2.Cells(i, 9).Value
      Next
  End Sub
       “输入常用备注”窗体的Initialize事件，窗体显示时MultiPage控件选择Page1页并将“维护”表中保存的常用备注信息加载到Page3页的列表框中。
        双击“输入常用备注”窗体的“确定”按钮，写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim str As String
      Dim dou As Double
      Dim i As Integer
      With MultiPage1
          Select Case .Value
              Case 0
                  For i = 1 To 6
                      str = str & .Page1.Controls("Label" & i) & Chr(9) & .Page1.Controls("TextBox" & i) & "元" & Chr(9)
                      If i = 2 Or i = 4 Then
                          str = str & Chr(10)
                      End If
                      dou = dou + Val(.Page1.Controls("TextBox" & i).Value)
                  Next
              Case 1
                  For i = 7 To 8
                      str = str & .Page2.Controls("Label" & i) & .Page2.Controls("TextBox" & i) & "元" & Chr(9)
                      dou = dou + Val(.Page2.Controls("TextBox" & i).Value)
                  Next
              Case 2
                  str = .Page3.ListBox1.Value
                  dou = 0
          End Select
      End With
      With 主界面.MultiPage1.Page2
          .TextBox6 = str
          .TextBox4 = IIf(dou <> 0, Format(dou, "0.00"), .TextBox4)
      End With
      Unload Me
  End Sub
       “输入常用备注”窗体中“确定”按钮的单击过程，将常用备注及小写金额写入到主界面窗体的备注文本框及小写金额文本框中。
        双击“输入常用备注”窗体中Page3页的列表框，写入下面的代码：
  Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
      主界面.MultiPage1.Page2.TextBox6 = MultiPage1.Page3.ListBox1
      Unload Me
  End Sub
       “输入常用备注”窗体中列表框的双击过程，将选中的备注写入到主界面窗体的备注文本框中。
        双击“输入常用备注”窗体中的TextBox1文本框，写入下面的代码：Private Sub TextBox1_AfterUpdate() MultiPage1.Page1.TextBox1 = Format(MultiPage1.Page1.TextBox1, "0.00") End Sub
       “输入常用备注”窗体中文本框的AfterUpdate事件过程，将金额格式化为两位小数格式。
其他文本框设置与之相同。

第11部分 其他应用
技巧197 收据系统 步骤7，在VBE窗口中选择“主界面”窗体的Page3页，在Page3页中添加一个ListView控件和三个按钮控件，如图 所示。

       双击窗体中的“查询”按钮，写入下面的代码：
  Private Sub CommandButton6_Click()
      Dim Itm As ListItem
      Dim r As Integer
      Dim c As Integer
      r = Sheet3.Range("A65536").End(xlUp).Row
      With MultiPage1.Page3.ListView1
          .ListItems.Clear
          For r = 2 To r
              Set Itm = .ListItems.Add()
              Itm.Text = Space(2) & Sheet3.Cells(r, 1)
              For c = 1 To 11
                  Itm.SubItems(c) = Sheet3.Cells(r, c + 1)
              Next
              Itm.SubItems(1) = Format(Itm.SubItems(1), "yyyy-mm-dd")
              Itm.SubItems(8) = Format(Itm.SubItems(8), "0.00")
          Next
      End With
      Set Itm = Nothing
  End Sub
       “查询”按钮的单击过程，将“存档”表中已开具收据的信息显示到ListView控件中，请参阅技巧131 。
        双击窗体中的“打印”按钮，写入下面的代码：
  Private Sub CommandButton5_Click()
      Dim r As Integer
      Dim rng As Range
      Dim str As String
      str = Val(MultiPage1.Page3.ListView1.SelectedItem)
      r = Sheet3.Range("A65536").End(xlUp).Row
      With Sheet3.Range("A2:A" & r)
          Set rng = .Find(What:=str, _
              After:=.Cells(.Cells.Count), _
              LookIn:=xlValues, _
              LookAt:=xlWhole, _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlNext, _
              MatchCase:=False)
          If Not rng Is Nothing Then
              If rng.Offset(0, 12).Text = "√" Then
                  MsgBox "已经打印的收据不可再打印!", 64, "提示"
              Else
                  With Sheet4
                      .Range("K1") = str
                      .PrintOut
                  End With
                  Sheet3.Range("M" & Rng.Row).Value = "√"
              End If
          End If
      End With
  End Sub
       “打印”按钮的单击过程，将“存档”表中已开具保存还没有打印的收据重新打印。
        第5行代码，将ListView控件中所选中的收据号码赋给变量str。
        第7行到第14行代码，使用该号码在“存档”表中查找数据。
        第16、17行代码，如果该号码所在行的M列已有打印标识则不能打印。
        第20、21行代码，如果该号码没有打印则将号码写入到“打印”表的K1单元格并打印收据。
        在日常使用时，如果确实要重新打印收据，可以以系统管理员身份进入系统，在窗体菜单中打开Excel，删除打印标识。
        步骤8，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件，在框架控件中添加一个标签控件，双击窗体写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim str As String
      str = Space(4) & "欢迎使用" & vbLf _
          & Space(4) & "使用前请仔细阅读使用说明：" & vbLf _
          & Space(4) & "一、第一次使用本系统时请以系统管理员身份登陆。
" & vbLf _
          & Space(4) & "二、第一次使用本系统时请先设置使用单位和添加用户。
" & vbLf _
          & Space(4) & "三、常用信息可以自行增加及删除。
" & vbLf _
          & Space(4) & "四、开具的收据只能打印一次，未打印的收据可以在查询界面中补充打印。
" & vbLf _
          & vbLf _
          & Space(4) & "使用过程中如有问题或好的建议请与我联系：" & vbLf _
          & Space(4) & "Tel：0513-86548930" & vbLf _
          & Space(4) & "Tel：13861958666" & vbLf _
          & Space(4) & "E-mail： yuanzhuping@yeah.net"
      Label8.Caption = str
      Label8.Height = 150
      Label8.Top = 6
      Label8.Left = 6
      Frame1.ScrollBars = fmScrollBarsVertical
      Frame1.ScrollHeight = Label8.Height
  End Sub
       使用窗体显示系统帮助信息，请参阅技巧122 。
窗体运行后效果如图所示。
               在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个Image控件和一个框架控件，在框架控件中添加一个Image控件和一个标签控件，在Image控件的属性窗口将其Picture属性设置为合适的图片，双击窗体写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim str As String
      str = Sheet2.Cells(2, 4) & "收据系统" & vbLf _
          & "版本： V2.0.00" & vbLf _
          & "版权： (C) 2009-2022" & vbLf _
          & "作者： yuanzhuping (2009-7-8)" & vbLf _
          & "邮箱： yuanzhuping@yeah.net "
      Label1.Caption = str
  End Sub
       使用窗体显示系统信息。
窗体运行后效果如图所示。
               步骤9，在“主界面”窗体的属性窗口中选择MultiPage控件，将其Style属性设置为2，使其不显示MultiPage控件的标签。
        步骤10，因为收据系统正常使用时只需在“主界面”窗体操作，所以隐藏工作簿，在VBE的“工程”窗口双击ThisWorkbook，在打开的代码窗口写入下面的代码：
  Private Sub Workbook_Open()
      Application.Visible = False
      登陆.Show
  End Sub
       收据系统打开时隐藏工作簿，显示“登陆”窗体供用户登陆。
        步骤11，使用收据系统，在打开时必需启用宏，所以将工作簿设置为禁用宏则关闭工作簿。
请参阅技巧44 。
        步骤12，设置VBA工程的密码。
示例VBA工程密码为六个8。
        保存工作簿后重新打开，显示如图所示的“登陆”窗体供用户登陆，第一次使用时默认用户为“系统管理员”，初始密码为六个8。
               在密码输入框中输入正确的密码后按“登陆”按钮后显示如图所示的“主界面”操作窗体。
               选择“系统”菜单，设置使用单位和用户后选择“操作”菜单中的“增加”菜单，进入如图所示的收据开具界面。
                选择“操作”菜单中的“查询”菜单，进入收据查询界面，按“查询”按钮后查询结果如图所示。
        .
上面的附件在查询后补发收据时有个错误，重新上传。

 

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=38
本帖已被收录到知识树中，索引项：开发帮助和教程
请问：如何再添加一个Page4？
右键
Snap1.jpg
版主你好，我是VBA新手，正在学习。
 我在EXCEl-VBA中复制了12-3的那段代码，然后F5运行的时候 出现一个选择宏的对话框，不能直接运行，而且宏对话框的选择里面也没有12-3那段代码的名字。
 我弄错了什么吗？ 谢谢
这代码是选择单元格后自动运行的，不能F5运行。

个人推荐利用Office OneNote做日常的代码收集整理，甚是便利，不妨一试。

Office OneNote还真没用过，谢谢推荐。

楼主貌似删了部分东西，1-9的附件都看不到了，望楼主早日归纳好1到11的所有知识和代码例子，发表出来供大家共享。
 楼主的功德一定会有所回报
东西是没有删，不过楼层好像有些错误，不知道为什么编辑好了以后，有时会相差10层。
 等结束后我会把所有资料发到目录的最后，方便大家下载。

尊敬的袁版主，请问其它的ID参数说明有没有，有，则发一个。

 

技巧51 不打开工作簿取得其他工作簿数据: 如果源数据表"数据表.xls"在别的地方,不如D或S盘上,上面的代码该如何调整?
Temp = ThisWorkbook.Path & "\数据表.xls" ThisWorkbook.Path 改成具体的完整路径，如Temp = "D:\数据表.xls"
谢谢,再问一下:
技巧51 不打开工作簿取得其他工作簿数据: 如果"数据表.xls"中, 实际要提取的数据在其中的sheet2中,sheet1有别的不相干的内容,那上面的代码(特别是SQL的方式)如何改?
我希望用其中的SQL方 ...
Sql = "select * from [Sheet2$]"
最近单位事很忙，下属公司要审计，同时我公司有幸被抽为全市10家重点税收检查单位（怎么好事轮不到），所以最近可能没时间更新了，请大家谅解。
最后的几个实例我会尽快完成的。

袁版主好久没上来更新了，想念ing...
谢谢大家的关心，我在前面说过了，最近单位工作很忙，可能要过了这段时间才能更新。
大家放心，本贴不会太监的，虽然还有几个就准备结束了。

袁老师，想询问一个问题，关于在窗体中增加菜单 点击某一个按钮，只能在模块中unload一个具体的窗体 如 unload userform1 有没有办法，实现 窗体不确定的关闭啊？ 如 unload me
因为菜单总是通用的嘛。

试试UserForms 集合对象On Error Resume Next Unload UserForms(0)

https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page=39
本帖已被收录到知识树中，索引项：开发帮助和教程
请问楼主,每行代码前面的
等,怎么得到的????
Word中有插入代码行号的代码。

本人想上传VBA常用技巧(1-197)之PDF档，但总是上传不成功！出现如下对话框！
谢谢ykx042907，在上传时先上传一部分的压缩文件，不要全部上传，然后再重新编辑，继续上传其他的文件。

支持！谢谢袁版主 基本上就是了，除了缺少3个技巧，最后的技巧顺序可能会调整一下，我想把最后一部分名称改为“综合实例”，只保留几个实例，其他的技巧调整到相应的分类中。

第11部分 其他应用
技巧198 职工考勤系统 笔者所在单位没有使用电子考勤，每到月底各部门需手工填写部门所有职工的考勤考核表及部门的考勤汇总表，工作量大、出错机率高、统计分析麻烦，因此使用VBA开发的考勤系统可以使部门考勤员简化工作，提高工作效率。
        步骤1，新建工作簿，将Sheet1工作表名称重命名为“资料”，设置成如图所示的格式，用来保存考勤系统使用过程中必需的资料。
 “资料”表中的B1单元格保存单位的名称，B2单元格保存考勤周期中开始考勤的日期，第三行以下用于保存考勤部门的资料，其中第四列往右的单元格保存部门职工的资料。

       步骤2，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件和两个按钮按件，在框架控件添加两个标签控件、一个文本框控件及一个组合框控件，调整好控件的大小与位置，如图所示。

       单位设置窗体用于设置使用单位及开始考勤的日期，双击窗体，在打开的代码窗口写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim arr As Variant
      TextBox1.SetFocus
      arr = Array("26日-25日", "27日-26日", "28日-27日", "1日-31日", "2日-1日", "3日-2日", "4日-3日", "5日-4日")
      With ComboBox1
          .List = arr
          .ListIndex = 0
      End With
  End Sub
       单位设置窗体的初始化事件，为组合框控件添加考勤周期。
        双击窗体中的“确定”按钮，在打开的代码窗口写入下面的代码：
  Private Sub CommandButton1_Click()
      If Trim(TextBox1) = "" Then
          MsgBox "请输入单位名称!", 64, "提示"
          TextBox1.SetFocus
          Exit Sub
      End If
      With Sheet1
          .Cells(1, 2) = Trim(TextBox1.Text)
          .Cells(2, 2) = Val(ComboBox1.Text)
          Application.Caption = .Cells(1, 2)
      End With
      Unload Me
  End Sub
       单位设置窗体中“确定”按钮的单击事件，将输入的单位名称及考勤周期的开始日期录入到”资料”表中并更新工作簿标题。
        步骤3，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个MultiPage（多页）控件，将MultiPage控件中的Page分别重命名为“增加”、“删除”和“编辑”。
        在“增加”页中添加一个框架控件和两个按钮按件，在框架控件添加三个标签控件及三个文本框控件，调整好控件的大小与位置，如图所示。

       双击“增加”按钮，在打开的代码窗口写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim r As Integer
      Dim i As Integer
      r = Sheet1.Range("A65536").End(xlUp).Row
      If Trim(MultiPage1.Page1.TextBox1.Text) = "" Then
          MsgBox "请输入部门名称!", 64, "提示"
          MultiPage1.Page1.TextBox1.SetFocus
          Exit Sub
      End If
      If Application.CountIf(Sheet1.Range("A:A"), MultiPage1.Page1.TextBox1.Text) > 0 Then
          MsgBox "部门名称已经存在,请重新输入!", 64, "提示"
          MultiPage1.Page1.TextBox1.SetFocus
          Exit Sub
      End If
      If Trim(MultiPage1.Page1.TextBox2.Text) = "" Then
          MsgBox "请输入部门负责人姓名!", 64, "提示"
          MultiPage1.Page1.TextBox2.SetFocus
          Exit Sub
      End If
      If Trim(MultiPage1.Page1.TextBox3.Text) = "" Then
          MsgBox "请输入考勤员姓名!", 64, "提示"
          MultiPage1.Page1.TextBox3.SetFocus
          Exit Sub
      End If
      For i = 1 To 3
          Sheet1.Cells(r + 1, i) = MultiPage1.Page1.Controls("TextBox" & i)
      Next
      MsgBox "部门已成功增加,请增加部门人员!", 64, "提示"
      Unload Me
  End Sub
       部门设置窗体中“增加”按钮的单击事件，将输入的部门名称、部门负责人及部门考勤员录入到”资料”表中。
        第5行到第9行代码，判断是否已输入部门名称。
        第10行到第14行代码，判断输入的部门名称是否重复。
        第15行到第19行代码，判断是否已输入部门负责人姓名。
        第20行到第24行代码，判断是否已输入部门考勤员姓名。
        第25行到第27行代码，将所输入的部门信息录入中资料表的最后一行。
        在“删除”页中添加一个框架控件和两个按钮按件，在框架控件添加一个列表框控件，调整好控件的大小与位置，如图所示。

       双击“删除”按钮，在打开的代码窗口写入下面的代码：
  Private Sub CommandButton2_Click()
      Dim r As Integer
      Dim s As String
      Dim i As Integer
      r = Sheet1.Range("a65536").End(xlUp).Row
      If MultiPage1.Page2.ListBox1.ListIndex < 0 Then
          MsgBox "请选择需要删除的部门!", 64, "提示"
          Exit Sub
      End If
      s = MultiPage1.Page2.ListBox1.Text
      If MsgBox("确定要删除" & s & "吗?", 36, "警告") = 6 Then
          For i = 4 To r
              If s = Sheet1.Cells(i, 1) Then
                  Sheet1.Cells(i, 1).EntireRow.Delete
                  MultiPage1.Page2.ListBox1.RemoveItem (ListBox1.ListIndex)
                  MsgBox s & "已经成功删除!", 64, "提示"
              End If
          Next
      End If
      Unload Me
  End Sub
       部门设置窗体中“删除”按钮的单击事件，删除“资料”表中已保存的部门资料。
        第6行到第9行代码，判断在列表框中是否已选择了要删除的部门。
        第10行代码，将所要删除的部门名称赋给变量s。
        第14行代码，将“资料”表中该部门所在的行删除。
        第15行代码，将列表框中该部门所在的行删除。
        在“编辑”页中添加一个框架控件和两个按钮按件，在框架控件添加四个标签控件、一个组合框控件及三个文本框控件，调整好控件的大小与位置，如图所示。

       双击窗体中的组合框控件，在打开的代码窗口写入下面的代码：
  Private Sub ComboBox1_Change()
      Dim r As Integer
      Dim c As Integer
      For r = 4 To Sheet1.Range("A65536").End(xlUp).Row
          If MultiPage1.Page3.ComboBox1 = Sheet1.Cells(r, 1) Then
              For c = 1 To 3
                  MultiPage1.Page3.Controls("TextBox" & c + 3) = Sheet1.Cells(r, c)
              Next
          End If
      Next
  End Sub
       组合框控件的Change事件，当用户选择所需编辑的部门名称后，文本框中显示该部门编辑前的信息。
        双击“编辑”按钮，在打开的代码窗口写入下面的代码：
  Private Sub CommandButton3_Click()
      Dim r As Integer
      Dim i As Integer
      Dim j As Integer
      r = Sheet1.Range("A65536").End(xlUp).Row
      If MultiPage1.Page3.ComboBox1.ListIndex < 0 Then
          MsgBox "请选择需要编辑的部门名称!", 64, "提示"
          Exit Sub
      End If
      If Trim(MultiPage1.Page3.TextBox4.Text) = "" Then
          MsgBox "部门名称不能为空!", 64, "提示"
          MultiPage1.Page3.TextBox4.SetFocus
          Exit Sub
      End If
      If Trim(MultiPage1.Page3.TextBox5.Text) = "" Then
          MsgBox "部门负责人不能为空!", 64, "提示"
          MultiPage1.Page3.TextBox5.SetFocus
          Exit Sub
      End If
      If Trim(MultiPage1.Page3.TextBox6.Text) = "" Then
          MsgBox "部门考勤员不能为空!", 64, "提示"
          MultiPage1.Page3.TextBox6.SetFocus
          Exit Sub
      End If
      If MsgBox("是否重新编辑" & MultiPage1.Page3.ComboBox1 & "的信息?", 36, "提示") = 6 Then
          For i = 4 To r
              If MultiPage1.Page3.ComboBox1 = Sheet1.Cells(i, 1) Then
                  For j = 1 To 3
                      Sheet1.Cells(i, j) = MultiPage1.Page3.Controls("TextBox" & j + 3)
                  Next
              End If
          Next
      End If
      Unload Me
  End Sub
       部门设置窗体中“编辑”按钮的单击事件，编辑“资料”表中已保存的部门信息。
        第6行到第9行代码，判断是否已选择了部门。
        第10行到第14行代码，判断部门名称是否为空。
        第15行到第19行代码，判断部门负责人是否为空。
        第20行到第24行代码，判断部门考勤员是否为空。
        第26行到第32行代码，将重新编辑的部门信息录入中资料表该部门所在的行中。
        步骤4，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件及一个按钮控件，在框架控件中添加两个标签控件、两个按钮控件、一个组合框控件、一个文本框控件及一个列表框控件，如图所示。

       双击窗体，在打开的代码窗口写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim i As Integer
      For i = 4 To Sheet1.Range("A65536").End(xlUp).Row
          ComboBox1.AddItem Sheet1.Cells(i, 1)
      Next
      ComboBox1.ListIndex = -1
  End Sub
       人员设置窗体的初始化事件，为组合框控件添加部门名称。
        双击窗体上的组合框控件，在打开的代码窗口写入下面的代码：
  Private Sub ComboBox1_Change()
      Dim r As Integer
      Dim c As Integer
      For r = 4 To Sheet1.Range("A65536").End(xlUp).Row
          If ComboBox1.Text = Sheet1.Cells(r, 1) Then
              ListBox1.Clear
              For c = 4 To Sheet1.Cells(r, 255).End(xlToLeft).Column
                  ListBox1.AddItem Sheet1.Cells(r, c).Value
              Next
          End If
      Next
      TextBox1.SetFocus
  End Sub
       组合框控件的Change事件，当用户选择所需增加或删除人员的部门名称后，文本框中显示该部门中已有的人员姓名。
        双击窗体上的“增加”按钮，在打开的代码窗口写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim i As Integer
      Dim c As Integer
      If ComboBox1.Text = "" Then
          MsgBox "请选择增加人员的部门!", 64, "提示"
          Exit Sub
      End If
      If Trim(TextBox1.Text) = "" Then
          MsgBox "请输入人员姓名!", 64, "提示"
          TextBox1.SetFocus
          Exit Sub
      End If
      With Sheet1
          For i = 4 To .Range("A65536").End(xlUp).Row
              If ComboBox1.Text = .Cells(i, 1) Then
                  c = .Cells(i, 255).End(xlToLeft).Column
                  If Application.CountIf(.Range(.Cells(i, 4), .Cells(i, c)), TextBox1) > 0 Then
                      MsgBox "人员姓名重复,请重新输入!", 64, "提示"
                      TextBox1 = ""
                      TextBox1.SetFocus
                      Exit Sub
                  Else
                      .Cells(i, c + 1) = TextBox1
                      ListBox1.AddItem TextBox1
                  End If
              End If
          Next
      End With
      TextBox1.Text = ""
      TextBox1.SetFocus
  End Sub
       人员设置窗体中“增加”按钮的单击事件，将输入的人员姓名保存到“资料”表中该人员所在部门的行中。
        第4行到第7行代码，判断是否已选择了所需增加人员的部门。
        第8行到第12行代码，判断是否已输入所增加的人员姓名。
        第15、16行代码，取得该部门在“资料”表中最右边列的列号。
        第17行到第22行代码，判断所增加的人员姓名是否重复。
        第23行代码，将所增加的人员姓名保存到“资料”表中。
        第24行代码，将增加的人员姓名添加到列表框中。
        第29、30行代码，清空文本框以便再次增加部门人员。
        双击窗体上的“删除”按钮，在打开的代码窗口写入下面的代码：
  Private Sub CommandButton2_Click()
      Dim i As Integer
      Dim c As Integer
      Dim j As Integer
      If ComboBox1.Text = "" Then
          MsgBox "请先选择一个部门!", 64, "提示"
          Exit Sub
      End If
      If ListBox1.ListIndex < 0 Then
          MsgBox "请选择需删除的人员姓名!", 64, "提示"
          Exit Sub
      End If
      With Sheet1
          If MsgBox("确定要删除" & ListBox1 & "吗?", 36, "警告") = 6 Then
              For i = 4 To .Range("A65536").End(xlUp).Row
                  If ComboBox1.Text = .Cells(i, 1).Value Then
                      c = .Cells(i, 255).End(xlToLeft).Column
                      For j = 4 To c
                          If .Cells(i, j) = ListBox1 Then
                            .Cells(i, j).Delete Shift:=xlToLeft
                          End If
                      Next
                  End If
              Next
              ListBox1.RemoveItem (ListBox1.ListIndex)
          End If
      End With
  End Sub
       人员设置窗体中“删除”按钮的单击事件，删除所选部门中的人员姓名。
        第5行到第8行代码，判断是否已选择了部门。
        第9行到第12行代码，判断是否已选择了所需删除的人员。
        第13行到第24行代码，删除该人员所在部门保存在“资料”表中该人员的单元格。
        第25行代码，从列表框中删除该人员。
        设置了使用单位、部门和人员的“资料”表如图所示。

第11部分 其他应用
技巧198 职工考勤系统 步骤5，将Sheet3工作表名称重命名为“考勤统计”，设置成如图所示的格式，用来汇总部门考勤考核数据及打印“考勤统计”表。

       步骤6，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件及两个按钮控件，在框架控件中添加四个标签控件、一个组合框控件、一个文本框控件和一个SpinButton控件，如图所示。

       双击窗体，在打开的代码窗口写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim i As Integer
      For i = 4 To Sheet1.Range("A65536").End(xlUp).Row
          ComboBox1.AddItem Sheet1.Cells(i, 1)
      Next
      ComboBox1.ListIndex = 0
      Label4 = Sheet1.Range("B1")
      SpinButton1.Value = Month(Date)
      TextBox1.Text = Year(Date) & "年" & Month(Date) & "月"
  End Sub
       部门考勤窗体的初始化事件，为组合控件添加部门名称，为文本框控件添加考勤月份。
        双击窗体上的SpinButton控件，在打开的代码窗口写入下面的代码：
  Private Sub SpinButton1_Change()
      With SpinButton1
          Select Case .Value
              Case 1 To 12
                  TextBox1 = Left(TextBox1, 4) & "年" & .Value & "月"
              Case Is > 12
                  .Value = 1
                  TextBox1 = Left(TextBox1, 4) + 1 & "年" & .Value & "月"
              Case Is < 1
                  .Value = 12
                  TextBox1 = Left(TextBox1, 4) - 1 & "年" & .Value & "月"
          End Select
      End With
  End Sub
       SpinButton控件的Change事件，调节文本框控件中的考勤月份。
        双击窗体上的“确定”按钮，在打开的代码窗口写入下面的代码：
  Private Sub CommandButton1_Click()
      Dim s As Integer
      Dim Sh As Worksheet
      Dim arr As Variant
      Dim arrName As Variant
      Dim i As Integer
      Dim i1 As Integer
      Dim j As Integer
      Dim j1 As Integer
      Dim r As Integer
      Dim c As Integer
      Dim str As String
      Dim d As Integer
      Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      For s = Worksheets.Count To 4 Step -1
          Worksheets(s).Delete
      Next
      Application.DisplayAlerts = True
      With Sheet1
          For i = 4 To .Range("A65536").End(xlUp).Row
              If ComboBox1.Text = .Cells(i, 1) And .Cells(i, 4) = "" Then
                  MsgBox "请增加部门人员!", 64, "提示"
                  Unload Me
                  Exit Sub
              End If
          Next
      End With
      With Sheet3
          .Unprotect
          r = .Range("B65536").End(xlUp).Row
          If r >= 50 Then
              .Rows("50:" & r).Delete Shift:=xlUp
          End If
          .Range("B1") = Sheet1.Range("B1") & "出缺勤统计表"
          .Range("C2") = ComboBox1.Text
          .Range("O2") = TextBox1.Text
          For i = 4 To Sheet1.Range("A65536").End(xlUp).Row
              If ComboBox1.Text = Sheet1.Cells(i, 1) Then
                  r = Sheet1.Cells(i, 255).End(xlToLeft).Column
                  .Range("C30") = Sheet1.Cells(i, 2)
                  .Range("O30") = Sheet1.Cells(i, 3)
                  For c = 4 To r
                      .Cells(c + 46, 2) = Sheet1.Cells(i, c)
                  Next
              End If
          Next
          r = .Range("B65536").End(xlUp).Row
          .Range("I50:I" & r).FormulaR1C1 = "=SUM(RC[-4]:RC[-1])"
          .Range("M50:M" & r).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
          .Range("B50:O" & r).Borders.LineStyle = xlContinuous
          .Range("C50:C" & r).Locked = False
          .Range("E50:H" & r).Locked = False
          .Range("J50:L" & r).Locked = False
          .ScrollArea = ""
          Application.Goto Reference:=.Range("A50"), Scroll:=True
          .ScrollArea = "A50:O" & r
          .Protect
          .EnableSelection = xlUnlockedCells
      End With
      For i = 4 To Sheet1.Range("A65536").End(xlUp).Row
          If ComboBox1.Text = Sheet1.Cells(i, 1) Then
              c = i
              For j = 4 To Sheet1.Cells(i, 255).End(xlToLeft).Column
                  str = str & Sheet1.Cells(i, j) & ","
              Next
          End If
      Next
      arrName = Split(Left(str, (Len(str) - 1)), ",")
      For i1 = 0 To UBound(arrName)
          Set Sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
          With Sh
              .Name = arrName(i1)
              arr = Array(1.75, 4.5, 3, 3, 3, 3, 45, 9, 1.75)
              For i = LBound(arr) To UBound(arr)
                  .Columns(i + 1).ColumnWidth = arr(i)
              Next
              arr = Array(33, 24, 18)
              For i = LBound(arr) To UBound(arr)
                  .Rows(i + 1).RowHeight = arr(i)
              Next
              .Rows("4:36").RowHeight = 16.5
              .Rows(37).RowHeight = 30
              .Range("B1:H1,B2:H2,C4:D4,E4:F4,B4:B5,G4:G5,H4:H5,B37:G37").Merge
              With .Range("B4:H37")
                  .Borders.LineStyle = xlContinuous

              End With
              With .Range("B1")
                  .HorizontalAlignment = xlCenter
                  .Value = Sheet1.Range("B1") & "人员考核记录表"
                  .Font.Name = "黑体"
                  .Font.Size = 16
                  .Font.Bold = True
              End With
              With .Range("B2")
                  .HorizontalAlignment = xlCenter
                  .Value = TextBox1.Text
                  .Font.Bold = True
              End With
              With .Range("B3")
                  .Value = "姓名：" & arrName(i1)
                  .HorizontalAlignment = xlLeft
                  .Font.Size = 10
              End With
              With .Range("B4：H37")
                  .HorizontalAlignment = xlCenter
                  .Font.Size = 10
              End With
              .Range("B4").Value = "日" & Chr(10) & "期"
              .Range("C4").Value = "上午"
              .Range("E4").Value = "下午"
              .Range("G4").Value = "工作内容（加班情况或外出记录）"
              .Range("H4").Value = "备注"
              .Range("C5,E5").Value = "到"
              .Range("D5,F5").Value = "缺"
              .Range("B37").Value = "本月考核得分总计"
              With .Range("B38")
                  .Value = "部门负责人：" & Sheet1.Cells(c, 2)
                  .HorizontalAlignment = xlLeft
                  .Font.Size = 10
              End With
              With .Range("H38")
                  .Value = "考勤员：" & Sheet1.Cells(c, 3)
                  .Font.Size = 10
                  .HorizontalAlignment = xlRight
              End With
              Select Case Val(Sheet1.Cells(2, 2))
                  Case 26 To 28
                      If Month(TextBox1.Text & "1日") <> 1 Then
                          .Cells(6, 2) = Year(TextBox1.Text & "1日") & "-" & Month(DateAdd("m", -1, TextBox1.Text & "1日")) & "-" & Val(Sheet1.Cells(2, 2))
                      Else
                          .Cells(6, 2) = (Year(TextBox1.Text & "1日") - 1) & "-" & Month(DateAdd("m", -1, TextBox1.Text & "1日")) & "-" & Val(Sheet1.Cells(2, 2))
                      End If
                  Case 1 To 5
                      .Cells(6, 2) = Year(TextBox1.Text & "1日") & "-" & Month(TextBox1.Text & "1日") & "-" & Val(Sheet1.Cells(2, 2))
              End Select
              For i = 1 To 30
                  Cells(i + 6, 2) = .Cells(6, 2) + i
                  If .Cells(i + 6, 2).Value = DateAdd("m", 1, .Cells(6, 2)) - 1 Then Exit For
              Next
              .Range("B6:B36").NumberFormatLocal = "d"
              For i = 6 To 36
                  If .Cells(i, 2) <> "" Then
                      Select Case DatePart("w", .Cells(i, 2))
                          Case 7, 1
                            .Cells(i, 7) = "休 息"
                          Case 2, 3, 4, 5, 6
                            .Cells(i, 3) = "√"
                            .Cells(i, 5) = "√"
                            .Cells(i, 7) = "上 班"
                            d = d + 1
                      End Select
                      Select Case Mid(Cells(i, 2), 6, Len(Cells(i, 2)) - 5)
                          Case "01-01"
                            .Cells(i, 3) = ""
                            .Cells(i, 5) = ""
                            .Cells(i, 7) = "元 旦"
                            d = d - 1
                          Case "05-01"
                            .Cells(i, 3) = ""
                            .Cells(i, 5) = ""
                            .Cells(i, 7) = "五一节"
                            d = d - 1
                          Case "10-01", "10-02", "10-03"
                            .Cells(i, 3) = ""
                            .Cells(i, 5) = ""
                            .Cells(i, 7) = "国庆节"
                            d = d - 1
                      End Select
                      Select Case Mid(NongLi(Cells(i, 2)), 9, 5)
                          Case "正月初一", "正月初二", "正月初三"
                            .Cells(i, 3) = ""
                            .Cells(i, 5) = ""
                            .Cells(i, 7) = "春 节"
                            d = d - 1
                          Case "四月初四"
                            .Cells(i, 3) = ""
                            .Cells(i, 5) = ""
                            .Cells(i, 7) = "清明节"
                            d = d - 1
                          Case "五月初五"
                            .Cells(i, 3) = ""
                            .Cells(i, 5) = ""
                            .Cells(i, 7) = "端午节"
                            d = d - 1
                          Case "八月十五"
                            .Cells(i, 3) = ""
                            .Cells(i, 5) = ""
                            .Cells(i, 7) = "中秋节"
                            d = d - 1
                      End Select
                  End If
              Next
              .Range("E3") = d
              d = 0
              .Range("H3").FormulaR1C1 = "=(COUNTA(R[3]C[-5]:R[33]C[-5],R[3]C[-3]:R[33]C[-3],""√"""""")-1)/2"
              .Range("H37").FormulaR1C1 = "=ROUND(IF(R[-34]C/R[-34]C[-3]*100>100,100,R[-34]C/R[-34]C[-3]*100),0)"
              .Range("E3,H3").Font.ColorIndex = 2
              .Range("C6:G36").Locked = False
              .Rows("6").Select
              .PageSetup.CenterHorizontally = True
              .DisplayAutomaticPageBreaks = False
              With ActiveWindow
                  .DisplayGridlines = False
                  .DisplayHeadings = False
                  .DisplayOutline = False
                  .FreezePanes = True
                  .DisplayGridlines = False
              End With
              .ScrollArea = "B1:O42"
              .Range("G6").Select
              .Protect
              .EnableSelection = xlUnlockedCells
          End With
      Next
      Sheets("考勤统计").Select
      Unload Me
      Application.ScreenUpdating = True
  End Sub
       部门考勤窗体中“确定”按钮的单击事件，将所考勤部门的人员姓名写入到“考勤统计”表的姓名列中并在工作簿中该部门所有人员的个人考核表。
        第15行到第19行代码，删除工作簿中原有的个人考核表。
        第20行到第28行代码，判断所要考勤的部门是否已添加了部门人员。
        第32行到第34行代码，删除“考勤统计”表中原有的统计数据，因为“考勤统计”表中B1：O30的表格是打印表格用的，统计数据是保存在B50以下单元格中，所以考勤前需要删除。
        第35行代码，将单位名称写入到“考勤统计”表的B1单元格。
        第36行代码，将考勤部门写入到“考勤统计”表的C2单元格。
        第4行代码，将考勤月份写入到“考勤统计”表的O2单元格。
        第41行代码，将部门负责人写入到“考勤统计”表的C30单元格。
        第42行代码，将考勤员写入到“考勤统计”表的O30单元格。
        第43行到第45行代码，将“资料”表中所保存的该部门人员姓名写入“考勤统计”表的B50及B50往下单元格中。
        第49、50行代码，在“考勤统计”表的I50、M50及以下单元格中写入合计公式并将单元格属性设置为锁定。
        第51行代码，将“考勤统计”表的B50至O列的最后一行单元格添加边框线。
        第52行到第54行代码，取消“考勤统计”表中需要编辑单元格的锁定属性。
        第55行到第57行代码，将“考勤统计”表的可选择区域设置为B50至O列的最后一行单元格并使用Goto方法选择B50单元格。
        第58、59行代码，保护“考勤统计”表，使之只能选择未锁定的单元格。
        写入考勤数据的“考勤统计”表如图所示。

       第61行到第69代码，将该部门保存在“资料”表中的人员姓名赋给数组arrName。
        第70、71行代码，根据数组arrName保存的人员姓名依次在工作簿中添加个人考核表。
        第73行代码，将添加的工作表以人员姓名重新命名。
        第74行到第83行代码，设置个人考核表的行高、列宽。
        第84行代码，合并个人考核表中的单元格。
        第85行到第88行代码，设置个人考核表的边框线。
        第59行到第127行代码，在个人考核表写入表格内容并设置格式。
        第128行到第142行代码，在个人考核表的日期栏中根据考勤月份及考勤周期写入考勤日期并设置自定义格式。
        第145行到第153行代码，使用DatePart函数判断考勤日期的星期并在个人考核表的“到”栏和“工作内容”栏中写入系统默认的内容，其中第152行代码，将应出勤天数赋给变量d。
        第154行到第170行代码，判断考勤日期是否是“元旦”、“五一节”及“国庆节”，如果是则去除个人考核表的“到”栏中的应出勤标志，在“工作内容”栏中写入节假日名称并将应出勤天数减去放假天数。
        第171行到第192行代码，判断考勤日期是否是“春节”、“清明节”、“端午节”及“中秋节”，如果是则去除个人考核表的“到”栏中的应出勤标志，在“工作内容”栏中写入节假日名称并将应出勤天数减去放假天数。
        判断考勤日期的农历日期需使用自定义函数，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：
  Public Function NongLi(Optional XX_DATE As Date)
      Dim MonthAdd(11), NongliData(99), TianGan(9), DiZhi(11), ShuXiang(11), DayName(30), MonName(12)
      Dim curTime, curYear, curMonth, curDay
      Dim GongliStr, NongliStr, NongliDayStr
      Dim i, m, n, k, isEnd, bit, TheDate
      代码略，详见附件
      NongliStr = "农历" & TianGan(((curYear - 4) Mod 60) Mod 10) & DiZhi(((curYear - 4) Mod 60) Mod 12) & "年"
      NongliStr = NongliStr & "(" & ShuXiang(((curYear - 4) Mod 60) Mod 12) & ")"
      If (curMonth < 1) Then
          NongliDayStr = "闰" & MonName(-1 * curMonth)
      Else
          NongliDayStr = MonName(curMonth)
      End If
      NongliDayStr = NongliDayStr & "月"
      NongliDayStr = NongliDayStr & DayName(curDay)
      NongLi = NongliStr & NongliDayStr
  End Function
       第195行代码，将统计出的应出勤天数写入到个人考核表的E3单元格。
        第197行代码，在个人考核表的H3单元格中写入统计实际出勤天数的公式。
        第198行代码，在个人考核表的H36单元格中写入计算考核得分的公式。
        第199行到第216行代码，设置个人考核表的页面格式及工作表保护。
        添加好的个人考核表如图所示。

       在实际应用时，系统统计出的出勤数据与实际出勤数据可能有出入，为了方便修改数据，在VBE中双击ThisWorkbook写入下面的代码：
  Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
      If Sh.Index > 3 And Target.Count = 1 Then
          If Sh.Range("B" & Target.Row) <> "" Then
              If Not Application.Intersect(Target, Union(Sh.Range("C6:C36"), Sh.Range("E6:E36"))) Is Nothing Then
                  Target = "√"
                  Target.Offset(, 1) = ""
              End If
              If Not Application.Intersect(Target, Union(Sh.Range("D6:D36"), Sh.Range("F6:F36"))) Is Nothing Then
                  Target = "△"
                  Target.Offset(, -1) = ""
              End If
          End If
      End If
  End Sub
       工作簿的SheetSelectionChange事件，选择个人考核表中的“到”或“缺”栏中的单元格时，自动在单元格中写入出缺勤标志。

  Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
      Dim rng As Range
      If Sh.Index > 3 And Target.Count = 1 Then
          If Sh.Range("B" & Target.Row) <> "" Then
              If Not Application.Intersect(Target, Sh.Range("C6:F36")) Is Nothing Then
                  Select Case Target
                      Case "√"
                          Sh.Range("G" & Target.Row) = "上 班"
                      Case "△"
                          Sh.Range("G" & Target.Row) = "缺 勤"
                      End Select
              End If
          End If
      End If
  End Sub
       工作簿的SheetChange事件，根据个人考核表中的“到”或“缺”栏中写入出缺勤标志自动调整工作内容栏中的工作内容。

第11部分 其他应用
技巧198 职工考勤系统 步骤7，在实际应用中，因为隐藏了工作表标签，当需要选择个人考核表时，只能使用自定义的菜单，所以在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：
  Sub check()
      On Error GoTo Line
      Sheets(4).Activate
      Exit Sub
  Line:
      MsgBox "本月还没有考勤,请先考勤!", 64, "提示"
  End Sub
       Check过程激活工作簿中的第四张工作表，也就是第一张个人考核表。
如果还没有进行部门考勤，激活命令会发生错误，所以使用On Error语句执行第6行代码进行提示。
        在修改个人考核表过程中，需要在工作簿中进行上下翻页，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：
  Sub NextPage()
      Select Case ActiveSheet.Index
          Case Is < 4
              MsgBox "请选择【个人考核】按纽!", 64, "提示"
          Case Is = Worksheets.Count
              MsgBox "已经是最后一页!", 64, "提示"
          Case Else
              Sheets(ActiveSheet.Index + 1).Activate
      End Select
  End Sub
       NextPage过程通过活动工作表的Index属性判断活动工作表是否在个人考核表的范围内，如果在则激活活动工作表的下一张工作表，否则进行提示。

  Sub Onpage()
      Select Case ActiveSheet.Index
          Case Is < 4
              MsgBox "请选择【个人考核】按纽!", 64, "提示"
          Case Is = 4
              MsgBox "已经是第一页!", 64, "提示"
          Case Else
              Sheets(ActiveSheet.Index - 1).Activate
      End Select
  End Sub
       Onpage过程通过活动工作表的Index属性判断活动工作表是否在个人考核表的范围内，如果在则激活活动工作表的上一张工作表，否则进行提示。
        步骤8，当所有的个人考核表修改完成后，需要对个人考核数据进行汇总，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：
  Sub Gather()
      Dim i As Integer
      If Worksheets.Count < 4 Then
          MsgBox "本月还没有考勤,请先进行部门考勤!", 64, "提示"
          Exit Sub
      End If
      With Sheet3
          .Select
          If MsgBox("是否汇总" & .Range("C2") & .Range("O2").Text & "份的考勤记录?", 36, "提示") = 6 Then
              .Unprotect
              For i = 50 To .Range("B65536").End(xlUp).Row
                  If .Cells(i, 2) <> "" Then
                  .Cells(i, 3) = Sheets(i - 46).Range("E3")
                  .Cells(i, 4) = Sheets(i - 46).Range("H3")
                  .Cells(i, 14) = Sheets(i - 46).Range("H37")
                  End If
              Next
          .Protect
          End If
      End With
  End Sub
       Gather过程将每个职工的个人考核表中的考核数据汇总到“考勤统计”表。
        第3行到第6行代码，判断是否已进行了部门考勤，因为如果还没有进行部门考勤，工作簿中只有三张工作表。
        第11行到第16行代码，将个人考核表中的应出勤天数、实际出勤天数及考核得分写入到“考勤统计”表第50行主以下的单元格中。
因为“考勤统计”表中的姓名和个人考核表的工作表名称的顺序是一致的，所以只需按顺序写入即可。
如果应出勤天数与实际情况有出入可以在“考勤统计”表的C列单元格中进行修改。
        步骤9，当汇总好考核数据后，需要打印“考勤统计”表和所有的个人考核表，在VBE窗口中单击菜单“插入”→“模块”，在打开的代码窗口写入下面的代码：
  Sub stamp()
      Dim i As Integer
      Dim r As Integer
      Dim a As Integer
      Dim p As Integer
      Dim c As Integer
      If Worksheets.Count < 4 Then
          MsgBox "本月还没有考勤,请先进行部门考勤!", 64, "提示"
          Exit Sub
      End If
      With Sheet3
          .Select
          If .Range("C50") = "" Then
              MsgBox "请先汇总考核数据!", 64, "提示"
              Exit Sub
          End If
          Application.ScreenUpdating = False
          If MsgBox("是否打印" & .Range("C2") & .Range("O2").Text & "份的考勤记录?", 36, "提示") = 7 Then
              Exit Sub
          End If
          .Unprotect
          r = .Range("B63536").End(xlUp).Row
          a = Abs(Int(-(r - 49) / 25))
          For p = 1 To a
              For i = 5 To 29
                  For c = 2 To 15
                      .Cells(i, c) = .Cells(i + 45 + (p - 1) * 25, c)
                  Next
              Next
              .PrintOut
          Next
          For i = 4 To Worksheets.Count
              Sheets(i).PrintOut
          Next
          .Protect
          .EnableSelection = 1
          Application.ScreenUpdating = True
      End With
  End Sub
       stamp过程打印“考勤统计”表和所有的个人考核表。
        第7行到第10行代码，判断是否已进行了部门考勤，因为如果还没有进行部门考勤，工作簿中只有三张工作表。
        第13行到第16行代码，判断是否已将考核数据进行汇总。
        第22、23行代码，计算“考勤统计”表需打印的张数，因为预设的表格只有25行，如果部门人数超过25人需要进行分次打印。
        第24行到第31行代码，将考核数据每次25行写入到打印表格中进行打印。
        第32行到第34行代码，打印所有人员的个人考核表。
        步骤10，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个Image控件、一个框架控件及一个按钮控件，在框架控件中添加一个Image控件和一个标签控件，将Image控件的Picture属性设置为合适的图片，如图 所示。

       双击窗体，在打开的代码窗口写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim Note As String
      Note = "名称： 职工考勤系统" & vbLf _
          & "版本： V2.0" & vbLf _
          & "作者： yuanzhuping" & vbLf _
          & "E-mail： yuanzhuping@yeah.net "
      Label1.Caption = Note
  End Sub
       “关于”窗体的初始化事件，使用标签控件显示系统信息。
        步骤11，在VBE窗口中单击菜单“插入”→“插入窗体”，在窗体中添加一个框架控件及一个按钮控件，在框架控件中添加一个标签控件，如图所示。

       双击窗体，在打开的代码窗口写入下面的代码：
  Private Sub UserForm_Initialize()
      Dim Note As String
      …………代码略，详见附件
      With Label1
          .Caption = Note
          .Height = 296
          .Top = 6
          .Left = 6
          Frame1.ScrollBars = fmScrollBarsVertical
          Frame1.ScrollHeight = .Height
      End With
  End Sub
       “帮助”窗体的初始化事件，使用标签控件显示帮助信息。
请参阅技巧122 。
        步骤12，在实际应用中，需要在菜单栏上添加自定义菜单来使用各项功能，在VBE窗口中单击菜单“插入”→“模块”，在模块中写入下面的代码：
  Sub AddNowBar()
      Dim NewBar As CommandBar
      On Error Resume Next
      With Application
          .CommandBars("Standard").Visible = False
          .CommandBars("Formatting").Visible = False
          .CommandBars("Stop Recording").Visible = False
          .CommandBars("toolbar list").Enabled = False
          .CommandBars.DisableAskAQuestionDropdown = True
          .DisplayFormulaBar = False
          .DisplayStatusBar = False
          .CommandBars("NewBar").Delete
      End With

      。

      End With
      Set NewBar = Nothing
      Application.StatusBar = ""
  End Sub
  Sub DelNowBar()
      On Error Resume Next
      With Application
          .CommandBars("Standard").Visible = True
          .CommandBars("Formatting").Visible = True
          .CommandBars("Stop Recording").Visible = True
          .CommandBars("toolbar list").Enabled = True
          .CommandBars.DisableAskAQuestionDropdown = False
          .DisplayFormulaBar = True
          .DisplayStatusBar = True
          .CommandBars("NewBar").Delete
          Application.StatusBar = False
      End With
  End Sub
       第1行到第19行代码，AddNowBar过程，去除工作簿中的菜单栏、工具栏、编辑栏及状态栏等，添加自定义的菜单栏。
        第20行到第33行代码，DelNowBar过程，恢复系统原来的设置。
        关于自定义菜单请参阅技巧83 。
        自定义菜单如图所示。

       为了使用自定义菜单，除了以上已经解析过的过程以外，还需在VBE窗口中单击菜单“插入”→“模块”，在模块中写入下面的代码：
  Sub SetUnits()
      If Sheet1.Cells(1, 2) <> "" Then
          If MsgBox("是否重新设置使用单位？", 36, "提示") = 7 Then
              Exit Sub
          End If
      End If
      单位设置.Show
  End Sub
  Sub Setbranch()
      If Sheet1.Cells(1, 2) = "" Then
          MsgBox "请先设置使用单位!", 36, "提示"
          Exit Sub
      End If
      部门设置.Show
  End Sub
  Sub Setcrew()
      If Sheet1.Cells(4, 1) = "" Then
          MsgBox "请先设置使用部门!", 64, "提示"
          Exit Sub
      End If
      人员设置.Show
  End Sub
  Sub Attendance()
      If Sheet1.Cells(4, 1) = "" Then
          MsgBox "请先设置使用部门!", 64, "提示"
          Exit Sub
      End If
      部门考勤.Show
  End Sub
  Sub backtrack()
      Sheet2.Select
  End Sub
  Sub ThemeHelp()
      关于.Show
  End Sub
  Sub OnHelp()
      帮助.Show
  End Sub
  Sub myQuit()
      If Workbooks.Count > 1 Then
          ThisWorkbook.Close
      Else
          Application.Quit
      End If
  End Sub
       第1行到第8行代码，“系统设置”菜单中的“单位设置”菜单指定的过程，显示“单位设置”窗体。
        第9行到第15行代码，“系统设置”菜单中的“部门设置”菜单指定的过程，显示“部门设置”窗体。
        第16行到第22行代码，“系统设置”菜单中的“人员设置”菜单指定的过程，显示“人员设置”窗体。
        第23行到第29行代码，“部门考勤”菜单指定的过程，显示“部门考勤”窗体。
其中第24行到第27行代码判断是否已设置了使用部门。
        第30行到第32行代码，“返回”菜单指定的过程，选择主界面表。
        第33行到第35行代码，“帮助”菜单中的“关于”菜单指定的过程，显示“关于”窗体。
        第36行到第38行代码，“帮助”菜单中的“帮助”菜单指定的过程，显示“帮助”窗体。
        第39行到第45行代码，“退出系统”菜单指定的过程，根据当前打开的工作簿数量采用Close方法关闭工作簿或Quit方法关闭应用程序。
        步骤13，为了在使用过程中有一个友好的用户界面，将Sheet2表重命名为“欢迎”，在工作表中插入合适的图片，在图片上添加标签控件并把宏指定给标签控件。
步骤14，在VBE窗口中双击“ThisWorkbook”，在打开的代码窗口中写入下面的代码：
  Private Sub Workbook_Open()
      With Sheet2
          .ScrollArea = "A1"
          .Select
      End With
  End Sub
  Private Sub Workbook_BeforeClose(Cancel As Boolean)
      Dim s As Integer
      Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      For s = Worksheets.Count To 4 Step -1
          Worksheets(s).Delete
      Next
      Application.DisplayAlerts = True
      Application.ScreenUpdating = True
      ThisWorkbook.Save
  End Sub
  Private Sub Workbook_Activate()
      Application.Caption = IIf(Sheet1.Cells(1, 2) <> "", Sheet1.Cells(1, 2), "")
      Call AddNowBar
  End Sub
  Private Sub Workbook_Deactivate()
      Application.Caption = ""
      Call DelNowBar
  End Sub
       第1行到第6行代码，工作簿的Open事件，打开考勤系统时选择欢迎界面。
        第7行到第17行代码，工作簿的BeforeClose事件，关闭考勤系统时删除所有的个人考核表。
        第18行到第21行代码，工作簿的Activate事件，考勤系统激活时创建自定义菜单。
        第22行到第25行代码，工作簿的Deactivate事件，考勤系统非激活时删除自定义菜单。
        步骤15，最后在VBE中将“资料”表的Visible属性设置为xlSheetVeryHidden使之隐藏；单击菜单“工具”→“数字签名”，为VBA工程签署数字证书。
        保存、关闭工作簿，重新打开工作簿，职工考勤系统如图所示。

技巧198职工考勤系统附件

 

 Private Sub Workbook_Deactivate()
   Application.Caption = ""
　　Call DelNowBar
  End Sub

 

from bs4 import BeautifulSoup
import requests

#url='https://club.excelhome.net/thread-395683-1-1.html'
headers={'User-Agent':'Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/118.0.0.0 Safari/537.36 Edg/118.0.2088.46'}
file=open('examplehtml.txt', 'w',encoding='utf-8') 
for i in range(1,41):
    url=f'https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page={i}'
    html=requests.get(url,headers=headers)
    bs = BeautifulSoup(html.text, 'lxml')
    #divlst=bs.find_all('div',class_='pcb') 
    divlst=bs.find_all('div',class_='pcb') 
    #print(divlst)
    file.write(url)
    #file.write(divlst.html)
    #file.write(divlst.text)
    for div in divlst:
        
        #print(div)
            file.write(div.text)
            #file.write(div.text)
            #file.write(div.get_text())
file.close()    


#alst=bs.find_all('a',attrs={'target':'_blank'}) 
#print(alst)
#for a in alst:
#    print(a.text)
#divlst=bs.find_all('div',class_='pcb') 
#divlst=bs.find_all('div',class_='pcb') 
#for div in divlst:
#    print(div.text)

 

from bs4 import BeautifulSoup

import requests

#url='https://club.excelhome.net/thread-395683-1-1.html'

headers={'User-Agent':'Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/118.0.0.0 Safari/537.36 Edg/118.0.2088.46'}

file=open('examplehtml.txt', 'w',encoding='utf-8')

for i in range(1,41):

    url=f'https://club.excelhome.net/forum.php?mod=viewthread&tid=395683&extra=&authorid=167149&page={i}'

    html=requests.get(url,headers=headers)

    bs = BeautifulSoup(html.text, 'lxml')

    #divlst=bs.find_all('div',class_='pcb')

    divlst=bs.find_all('div',class_='pcb')

    #print(divlst)

    file.write(url)

    #file.write(divlst.html)

    #file.write(divlst.text)

    for div in divlst:

       

        #print(div)

            file.write(div.text)

            #file.write(div.text)

            #file.write(div.get_text())

file.close()    

#alst=bs.find_all('a',attrs={'target':'_blank'})

#print(alst)

#for a in alst:

#    print(a.text)

#divlst=bs.find_all('div',class_='pcb')

#divlst=bs.find_all('div',class_='pcb')

#for div in divlst:

#    print(div.text)