EXCEL VBA 备忘录

太过爱你忘了你带给我的痛 2022-05-31 00:14 372阅读 0赞

最最基础的什么录制，加快捷键，被禁用宏，……等基本操作直接过滤，这些还不会的，请百度。此文主要备忘常用的编程语句或语法。

range(“A1”).value     对象和属性之间用点连接，value代表单元格值

range(“A1”).select    select表示在a1单元格上执行选择

public sub mysub()

magbox "hello world!"   ‘magbox是弹出提示框，后面双引号为弹出的内容

end sub

<table>      
 <tbody> 
  <tr> 
   <td>数据类型</td> 
   <td>存储空间（字节）</td> 
   <td>范围描述</td> 
  </tr> 
  <tr> 
   <td>Byte</td> 
   <td>1</td> 
   <td>保存0--255的整数</td> 
  </tr> 
  <tr> 
   <td>Boolean</td> 
   <td>2</td> 
   <td>保存逻辑判断的结果：True或False</td> 
  </tr> 
  <tr> 
   <td>Integer</td> 
   <td>2</td> 
   <td>保存-32768--32768的整数</td> 
  </tr> 
  <tr> 
   <td>Long</td> 
   <td>4</td> 
   <td>保存-2147483648--2147483648的整数</td> 
  </tr> 
  <tr> 
   <td>Single</td> 
   <td>4</td> 
   <td>负值范围：-3.402823E38-- -1.401298E-45<br> 正值范围：1.401298E-45-- 3.402823E38</td> 
  </tr> 
  <tr> 
   <td>Double</td> 
   <td>8</td> 
   <td>负值范围：-1.79769313486232E308-- -4.94065645841247E-324<br> 正值范围：4.94065645841247E-324-- 1.79769313486232E308</td> 
  </tr> 
  <tr> 
   <td>Currency</td> 
   <td>8</td> 
   <td>数值范围：-922337203685477.5808-- 922337203685477.5807</td> 
  </tr> 
  <tr> 
   <td>Decimal</td> 
   <td>14</td> 
   <td>不含小数时：+/-79228162514264337593543950335<br> 包含小数时：+/-7.9228162514264337593543950335<br> 最小非零数字：+/-0.000000000000000000000000001</td> 
  </tr> 
  <tr> 
   <td>Date</td> 
   <td>8</td> 
   <td>日期范围：100年1月1日--9999年12月31日<br> 时间范围：0:00:00--23:59:59</td> 
  </tr> 
  <tr> 
   <td>String(变长)</td> 
   <td>10字节加字符串长度</td> 
   <td>0到大约20亿个字符</td> 
  </tr> 
  <tr> 
   <td>String(定长)</td> 
   <td>字符串长度</td> 
   <td>1到大约65400个字符</td> 
  </tr> 
  <tr> 
   <td>Object</td> 
   <td>4</td> 
   <td>对象变量，用来引用对象</td> 
  </tr> 
  <tr> 
   <td>Variant(变体型)</td> 
   <td>&nbsp;</td> 
   <td>除了定长String数据及用户定义类型外，可以包含任何种类的数据。如果是数值，最大可达Double的范围;如果是字符，与变长String的范围一样</td> 
  </tr> 
  <tr> 
   <td>用户自定义</td> 
   <td>&nbsp;</td> 
   <td>每个元素的范围与它本身的数据类型的范围相同</td> 
  </tr> 
 </tbody> 
</table>

Dim 变量名 As 数据类型  变量名必须以字母（或汉字）开头，不能包含标点符号，不超过255个字符（1汉字=2字符）

dim str as string\*10  表示这个变量只能存储10个字符

dim str$    $表示把变量声明为string变量类型

integer: %   long: &  single: !   double: \#   currency: @   string: $

声明多个变量，可以写在同一个dim后面，变量名之间用逗号隔开。

如果不指定变量类型，则变量声明为Variant类型

设置强制申明变量

option explicit

sub test()

a = "我是变量！"

msgbox a

end sub

运行会提示没有申明变量

public 变量名 as 数据类型  变量将被申明为公共变量

private 变量名 as 数据类型  变量将被申明为私有变量

static 变量名 as 数据类型  变量将被申明为静态变量，在整个代码运行期间都会保留该变量的值

const p as single = 3.14      申明single常量，名称为p,值为3.14

dim  arr（1 to 50）as string    该语句声明一个string类型的数组，名称为arr，可以存储50个元素  
arr(1) = 1 给变量赋值  
sub sztest\_2()  
  dim arr(1 to 10) as integer, i as integer  
  for i = 1 to 10  
    arr(i) = i  
  next  
end sub  
  
dim arr(1 to 3,1 to 20)  声明多维数组  
dim arr(2,19) 与上面一样，不同的写法  
定义变量时 arr(1,2) = ??  
  
sub dtsz()  
  dim arr()  as string   '定义数组  
  dim n as long  
  '统计A列有多少个非空单元格  
  n = application.worksheetfunction.counta(range("a:a"))  
  redim arr(1 to n) as string  '重新定义数组的大小  
end sub  
使用dim语句声明变量时，括号内的参数不能是变量，所以必须用redim语句重新指定大小  
用这样的方式声明的数组称为动态数组  
已经定义大小的数组同样可以用redim语句重新指定它的大小。  
  
sub arraytest()  
  dim arr as variant   '使用array函数创建数组，定义变量时，变量类型必须为Variant  
  '将1到10十个自然数赋给数组arr  
  arr = array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)  '参数是用英文逗号隔开的列表  
  msgbox "arr数组的第2个元素为：" & arr(1)    
end sub  
  
sub splittest()  
  dim arr as variant   '变量类型必须为Variant  
  '利用split生成数组  
  arr = split("邓城,林梅,张青,孔丽,冯继伟,孔佳",",")  '第2参数为分隔符  
  msgbox "arr数组的第2个元素为：" & arr(1)    
end sub  
  
  
sub angarr()  
  dim arr as variant   '变量类型必须为Variant  
  arr = range("a1:c3").value '将a1:c3单元格的内容存储到数组arr里  
  range("e1:g3").value =arr  '将数组arr的数据写入E1：G3单元格区域    
end sub  
  
一个一维数组arr，它的最大索引号是UBound(arr);它的最小索引号LBound(arr)；计算数组有多少个元素UBound(arr)-LBound(arr)+1  
  
sub arrcount()  
  dim arr(10 to 50)  
  msgbox "数组的最大索引号是：" & UBound(arr) & chr(13)\_  'chr(13)代表一个回车符，相当于按了一次回车键  
  & "数组的最小索引号是：" & LBound(arr) & chr(13)\_  
  & "数组的元素个数是：" & UBound(arr)-LBound(arr)+1   '&：连接运算符，将两个字符串合并成一个字符串  
end sub  
  
如果是多维数组  
sub dwsz()  
  dim arr(1 to 10,1 to 100)  
  msgbox "第一维的最大索引号是：" & UBound(arr，1) & chr(13)\_  'chr(13)代表一个回车符，相当于按了一次回车键  
  & "第一维的最大索引号是：" & LBound(arr，2)  
end sub  
  
join 函数  
此函数将一个一维数组里的元素使用指定的分隔符连接成一个新的字符串  
sub jointest()  
  dim arr as variant, txt as string   '定义2个变量  
  arr = array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9) '利用array函数创建一个数组arr  
  txt = join(arr,"@")  '将arr数组的元素连接成字符串，用@作分隔符  
  msgbox txt  
end sub  
  
  
sub arrtorng1()  
  dim arr as variant  
  arr = array(1, 2, 3, 4, 5, 6, 7, 8, 9)    
  '将数组批量写入单元格  
  range("a1:a9").value = application.worksheetfunction.transpose(arr)  ' 将一维数组写入单元格区域，必须在同一行，如果要写入一列，必须先使用transpose 函数转置  
end sub  
  
sub arrtorng2()  
  dim arr(1 to 2,1 to 3) as string  '定义一个2行3列的二维数组  
  arr(1, 1) = 1  
  arr(1, 2) = "张勇"  
  arr(1, 3) = "男"  
  arr(2, 1) = 2  
  arr(2, 2) = "林梅"  
  arr(2, 3) = "女"  
  range("a1:c2").value = arr  '将数组批量写入单元格区域，6个元素对应6个单元格，且数组与单元格都是2行3列  
end sub  
  
application.workbooks("book1").worksheets("sheet2").range("a2")    '不同级别的对象之间用 . 连接  
application 代表excel程序  
workbooks   工作簿集合，表示打开的所有工作簿  
book1       工作簿的名称  
worksheets  工作表集合，表示指定工作簿的所有工作表  
  
运算符：+  -  \*  /  \\(整除)  ^(指数运算)  Mod（求模运算，取余数）  
比较运算符：=  <  >   <=  >=  <>  is(比较两个对象的引用变量)  like(比较两个字符串是否匹配)  
VBA中的通配符：  \*  ？  \#（任意一个数字）  \[charlist\]（代替位于charlist中的任意一个字符）     \[!charlist\]（代替不在charlist中的任意一个字符）  
逻辑运算符： and=与   or=或    not=非  xor=异或  eqv=等价   imp=蕴含  
运算符的优先级   （） ^  -(求相反数)  \*,/  \\   mod  +,-  &,+  =,<>,<,>,<=,>=,like,is  and,or,not,xor,eqv,imp  
  
  
sub nowtime()  
  msgbox"现在的时间是：" &time()  'time函数返回当前系统时间  
end sub  
  
if time <0.5 then msgbox "早上好！"  
if: 如果  
time:函数返回当前系统时间  
<:判断当前系统时间是否小于中午12点，返回TRUE或者FALSE  
0.5：2分之1天，即12小时，表示中午12点。  
then:那么  
  
sub sayhello()  
  if time<0.5 then msgbox "早上好！"  
  if time>=0.5 then msgbox "下午好！"  
end sub  
  
if time<0.5 then msgbox "早上好！" else msgbox "下午好！"  
  
if time<0.5 then  
 msgbox "早上好！"  
else  
 msgbox "下午好！"  
end if  
  
if time<0.5 then  
 msgbox "早上好！"  
else if time>0.75 then  
 msgbox "晚上好！"  
else  
 msgbox "下午好！"  
end if  
  
select case time  
  case is<0.5  
    msgbox "早上好！"  
  case is>0.75  
    msgbox "晚上好！"  
    case else  
  msgbox "下午好！"  
end select  
  
  
sub xingji()  
  dim xj as string  
  select case cells(2, "H")  '表示H2  
    case is <85  
      xj = "不评定"  
    case is <100  
      xj = "一星级"  
    case is <115  
      xj = "二星级"  
    case is <130  
      xj = "三星级"  
    case is <150  
      xj = "四星级"  
    case else  
      xj = "五星级"  
  end select  
  cells(2,"i") = xj  
end sub  
  
sub xingji()  
  dim xj as string,i as integer  
  for i = 2 to 19 step 1  
    select case cells(i, "H")    
      case is <85  
        xj = "不评定"  
      case is <100  
        xj = "一星级"  
      case is <115  
        xj = "二星级"  
      case is <130  
        xj = "三星级"  
      case is <150  
        xj = "四星级"  
      case else  
        xj = "五星级"  
    end select  
    cells(i,"I") = xj  
  next i  
end sub  
  
  
sub xingji()  
  dim xj as string,i as integer  
  i = 2  
  do while cell(i, "H")<>""  
     select case cells(i, "H")    
      case is <85  
        xj = "不评定"  
      case is <100  
        xj = "一星级"  
      case is <115  
        xj = "二星级"  
      case is <130  
        xj = "三星级"  
      case is <150  
        xj = "四星级"  
      case else  
        xj = "五星级"  
    end select  
    cells(i,"I") = xj  
  i = i + 1  
  loop  
end sub  
  
sub xingji\_1()  
  dim xj as string,i as integer  
  i = 2  
  do until cell(i, "H") = ""  
     select case cells(i, "H")    
      case is <85  
        xj = "不评定"  
      case is <100  
        xj = "一星级"  
      case is <115  
        xj = "二星级"  
      case is <130  
        xj = "三星级"  
      case is <150  
        xj = "四星级"  
      case else  
        xj = "五星级"  
    end select  
    cells(i,"I") = xj  
i = i + 1  
  loop  
end sub  
  
  
sub shtname()  '把所有当前工作簿的工作表名称按次序写入A列  
  dim sht as worksheet,i as integer   '定义变量，因为在工作表集合里循环，所以变量类型必须定义为worksheet，即工作表类型  
  i = 1  
  fro each sht in worksheets    'worksheets当前活动工作簿中的所有工作表的集合，集合里有几个工作表对象，运行程序后就执行循环体几次。  
     cells(i, "A") = sht.name   'sht.name 返回变量sht代表的工作表的标签名称  
     i = i + 1  
  next sht                      '返回for each语句开始处，再次执行循环体，变量名可以省略，直接写next  
end sub  
  
  
sub he()  
  dim mysum as long, i as integer  
  i = 1  
x: mysum = mysum + i                       'x:标签就像公路旁的指示牌，告诉驾驶员应该把车开向哪里。如果是字符串标签，请记得在后面加上英文冒号。  
  i = i + 1  
  if i <=100 then goto x                   '如果i小于或等于100,转到x标签处；不管是文本标签还是数字标签，GOTO后面的标签名都不加冒号和引号  
  msgbox "1到100的自然数和是：" & mysum      
end sub  
  
  
sub fontset()  
   worksheets("sheet1").range("a1").font.name = "仿宋"   '设置字体  
   worksheets("sheet1").range("a1").font.size = 12       '设置字号  
   worksheets("sheet1").range("a1").font.bold = True     '设置字体加粗  
   worksheets("sheet1").range("a1").font.colorindex = 3  '设置字体颜色  
end sub  
  
sub fontset()  
   with worksheets("sheet1").range("a1").font  
       .name = "仿宋"   '设置字体  
       .size = 12       '设置字号  
       .bold = True     '设置字体加粗  
       .colorindex = 3  '设置字体颜色  
   end with  
end sub  
  
sub macro1()       'macro1是过程名称，过程总是以sub过程名和一对括号开始  
  range("A1:A8").select    '操作EXCEL或处理数据的代码，一个过程可以有任意多的代码  
  selection.copy  
  range("C1").select  
  activesheet.paste  
end sub            '所有的sub过程都是以end sub结束  
  
  
\[Private|Public\] \[Static\] Sub 过程名（\[参数列表\]）     
'private和public用于声明过程的作用域名，同时只能选用1个，如果省略，过程默认为公共过程；如果选用Static，运行程序的过程中将保存该过程里声明的本地变量  
  \[语句块\]  
  \[Exit Sub\]      'exit sub 可选语句，执行它将中断执行并退出过程  
  \[语句块\]        '所有\[\]内的内容都是可选的  
End Sub      
  
  
在A过程中调用B过程  
sub runsub()  
  sayhello          '过程名\[参数1，参数2\]  
end sub  
  
sub runsub\_2()  
  call sayhello      'call过程名\[参数1，参数2\]  
end sub  
  
sub runsub\_3()  
  application.run"sayhello"   ' application.run 表示过程名的字符串（或字符串变量）\[参数1，参数2\]  
end sub  
  
function fun()    '自定义函数function  
  fun = int(rnd()\*10) + 1  
end function  
  
function countcolor()  
  if range("A1").interior.color = rgb(255,255,0) then  
    countcolor = 1  
  else  
    countcolor = 0  
  end if  
end function  
  
function countcolor()   '统计底纹颜色为黄色的单元格数量  
  dim rng as range  
  for each rng in range("A1:A10")   '使用for each语句遍历A1:A10里的所有单元格，依次对A1:A10区域中的各个单元格进行判断  
    if rng.interior.color = rgb(255,255,0) then      '在for each 循环语句里嵌套if语句  
      countcolor = countcolor + 1                  '如果单元格的底纹颜色为黄色，函数值增加1  
    end if  
  next rng  
end function  
  
还可以通过索引号来引用某个颜色  
range("A1").interior.colorindex = 6   '6表示黄色的索引号  
  
  
function countcolor(arr as range)   '指定函数的参数为一个range型，即单元格变量，名称为arr  
  dim rng as range  
  for each rng in arr     '依次判断arr变量，代表的单元格区中每个单元格的底纹颜色  
    if rng.interior.color = rgb(255,255,0) then  
       countcolor = countcolor + 1  
    end if  
  next rng  
end function  
为函数设置参数之后，如果要统计A1：C10中的黄色底纹单元格的个数，输入“=countcolor(A1：C10)”即可  
  
  
function countcolor(arr as range，c as range)   '指定函数的第二个参数为一个range型变量，名称为c  
  dim rng as range  
  for each rng in arr       
    if rng.interior.color = c.interior.color then  '依次判断单元格的颜色是否与函数第2参数的单元格的底纹相同  
       countcolor = countcolor + 1  
    end if  
  next rng  
end function  
输入“=countcolor(A1：C10，E1)”  
  
  
public function fun()      
  application.volatile True     '新添加的语句，写在过程开始的第一句  
  fun = int(rnd()\*10) + 1  
end function  
使用application.volatile True 语句是将自定义函数声明为易失性函数。当工作表发生重算后，易失性函数会重新计算函数的值。  
  
声明函数过程，规范的语句  
\[Public|private\]\[Static\]Function 函数名(\[参数列表\])\[As 数据类型\]  
  \[语句块\]  
  \[函数名=过程结果\]  
  \[Exit Function\]  
  \[语句块\]  
  \[函数名=过程结果\]  '最后必须把函数计算的结果赋给函数名。这一步必不可少。  
End Function  
  
application:代表EXCEL应用程序  
workbook:代表excel中的工作簿，一个workbook对象代表一个工作簿文件  
worksheet:代表excel中的工作表，一个worksheet对象代表工作簿里的一张普通工作表  
range:代表excel中的单元格，可以是单个单元格，也可以是单元格区域  
  
application.screenupdating = false    '关闭屏幕更新  
application.screenupdating = True     '恢复屏幕更新  
  
application.displayalerts = false     '不显示警告信息  
application.displayalerts = True      '恢复显示警告信息  
  
  
private sub worksheet\_selectionchange(byval target as range)   'target变量代表用户当前选中的单元格  
   target.value = target.address      '将选中的单元格地址写入该单元格  
end sub  
  
private sub worksheet\_selectionchange(byval target as range)   'target变量代表用户当前选中的单元格  
   target.value = target.address      '将选中的单元格地址写入该单元格  
   application.enableevents = false   '禁用事件  
   target.offset(1,0).select          '选中活动单元格下面的一个单元格  
   application.enableevents = true    '启用事件  
end sub  
  
  
sub counttest()  
   dim mycount as integer,rng as range  
   for each rng in range("a1:b50")                      '在A1：B50单元格里循环  
       if rng.value > 1000 then mycount = mycount + 1   '如果满足条件，数量+1  
   next  
   msgbox "a1:b50中大于1000的单元格个数为：" & mycount  '提示框显示结果  
end sub  
  
sub counttest()  
   dim mycount as integer  
   mycount = application.worksheetfunction.countif(range("A1:B50"),">1000")  
   msgbox "a1:b50中大于1000的单元格个数为：" & mycount  '提示框显示结果  
end sub  
使用工作表函数时，应加上application.worksheetfunction  
  
  
application.caption = "microsoft excel"   '修改标题栏  
application.displayformulabar = False     '隐藏编辑栏  
application.displaystatusbar = False      '隐藏状态栏  
application.statusbar = "正在计算，请稍等......"      '更改状态栏中显示信息  
application.statusbar = False      '恢复状态栏为初试状态  
activewindow.displayheadings =  False    '隐藏行标和列标  
  
activewindow.displayworkbooktabs =  False   '隐藏工作表标签  
activewindow.displayhorizontalscrollbar =  False   '隐藏水平滚动条  
activewindow.displayverticalscrollbar =  False   '隐藏垂直滚动条  
application.commandbars("darwing").visible = False   '显示绘图工具栏  
application.commandbars("standard").visible = False   '隐藏常用工具栏  
activewindow.displaygridlines =  False   '隐藏网格线  
  
application的常用属性  
activecell       当前活动单元格  
activechart      当前活动工作簿中的活动图表  
activesheet      当前活动工作簿中的活动工作表  
activewindow     当前活动窗口  
activeworkbook   当前活动工作簿  
charts           当前活动工作簿中所有的图表工作表  
selection        当前活动工作簿中所有选中的对象  
sheets           当前活动工作簿中所有sheet对象，包括普通工作表、图表工作表、msexcel4.0宏表工作表和msexcel5.0对话框工作表  
worksheets       当前活动工作簿中的所有worksheet对象（普通工作表）  
workbooks        当前所有打开的工作簿  
  
sub wbmsg()  
  range("b2") = thisworkbook.name    'thisworkbook代码所在的工作簿  
  range("b3") = thisworkbook.path  
  range("b4") = thisworkbook.fullname  
end sub  
   
workbooks.add  '不带任何参数，将创建包含一定数据空白工作表的新工作簿  
workbooks.add "c:\\program files\\microsoft office\\templates\\2052\\address.xls"  'add后面有一个空格，参数是现有excel文件名的字符串。选用该参数，新建的工作簿将以该文件作为模板  
workbooks.add xlwbatchart '参数告诉vba 新建的工作簿包含1张图表工作表  
xlwbatchart  图表工作表；xwbatworksheet 普通工作表；xlwbatexcel4macrosheet  ms excel 4.0宏表工作表；xlwbatexcel4intlmacrosheet ms excel 5.0对话框工作表  
  
sub openfile()  
  workbooks.open filename:="f:\\book1.xls"  '打开F盘的Book1.xls也可以写成 workbooks.open "f:\\book1.xls"  
end sub  
  
sub jhwb()  
  workbooks("book1").activate      '激活book1工作簿  
end sub  
  
sub savewb()  
  thisworkbook.save  '保存代码所在的工作簿  
end sub  
  
sub savetofile()  
  thisworkbook.saveas filename:="d:\\test.xls"  '参数指定文件保存的路径及文件名，如果省略路径，默认将文件保存在当前文件夹中  
end sub  
  
sub closewb()  
  workbooks.close  '关闭所有打开的工作簿  
end sub  
  
sub closewb()  
  workbooks("book1").close  '关闭book1  
end sub  
  
sub closewb()  
  workbooks("book1").close  savechanges:=true   '关闭并保存修改 也可以写成  workbooks("book1").close  true  
end sub  
  
sub wb()  
  workbooks.add  
  msgbox "代码所在的工作簿为：" & thisworkbook.name   '显示代码所在工作簿名称  
  msgbox "当前活动工作簿为：" & activeworkbook.name   '显示当前活动工作簿名称  
  activeworkbook.close savechanges:=false             '关闭新建工作簿，不保存修改  
end sub  
  
wroksheets.item(1)   '引用工作簿里的第一张工作表  
worksheets(1)        '引用工作簿里的第一张工作表  
worksheets("sheet1") '引用工作簿里标签名称为“sheet1”的工作表  
  
sheet1.range("a1") = 100   '在指定工作表A1单元格输入100  
  
  
worksheets.add   '插入一张新工作表  
worksheets.add before:=worksheets(1)  '在第一张工作表前插入一张新工作表  
worksheets.add after:=worksheets(1)  '在第一张工作表后插入一张新工作表  
worksheets.add count:=3   '在活动工作表前插入3张工作表  
worksheets.add after:=worksheets(1),count:=3    '在第一张工作表后插入3张工作表  
  
worksheets(2).name = "工资表"    '更改第2张工作表的标签名称为“工资表”  
  
sub shtadd()  
  worksheets.add before:=worksheets(1)  
  activesheet.name = "工资表"  
end sub  
  
sub shtcopy()  
  worksheets("工资表").copy before:=worksheets("出勤登记表")  
end sub  
  
sub shtcopy()  
  worksheets("工资表").copy after:=worksheets("职工档案")  
end sub  
  
不使用参数，默认将工作表复制到新工作簿中  
sub shtcopy()  
  worksheets("工资表").copy  
end sub  
  
移动工作表  
sub shtmove()  
  '将“工资表”移动到“出勤登记表”之前  
  worksheets("工资表").move before:=worksheets("出勤登记表")  
  '将“工资表”移动到“职工档案”之后  
  worksheets("工资表").move after:=worksheets("职工档案")  
  '将“工资表”移动到新工作簿中  
  worksheets("工资表").move  
end sub  
  
隐藏或显示工作表  
Worksheets("工资表").Visible = False  
Worksheets("工资表").Visible = xlSheetHidden  
Worksheets("工资表").Visible = 0  
这3句的作用是一样的  
  
Worksheets("工资表").Visible = xlSheetVeryHidden  
Worksheets("工资表").Visible = 2  
这2句只能在属性窗口取消隐藏  
  
显示工作表  
Worksheets("工资表").Visible = True  
Worksheets("工资表").Visible = xlSheetVisible  
Worksheets("工资表").Visible = 1  
Worksheets("工资表").Visible = -1  
  
Sub shtcount()  
  Dim mycount%  
  mycount = Worksheets.Count  
  MsgBox "工作簿里一共有" & mycount & "张工作表！"  
End Sub  
  
Worksheets("sheet1").Range("a1") = 50   '这就是地址，地址告诉vba应该把数据保存在哪里。  
Sub rng()  
  Range("a1:a10").Value = 200  
  Dim n As String  
  n = "b1:b10"  
  Range(n) = 100  
End Sub  
  
Sub rng()  
  Range("date").Value = 100  'date参数是表示名称名的字符串，即单元格名称  
End Sub  
Sub rng()  
  Range("a1:a10,a4:e6,c3:d9").Select    '选中单元格区域  
End Sub  
Sub rng()  
  Range("b1:b10 a4:d6").Select  '选中多个单元格区域的交集  
End Sub  
Sub rng()  
  Range("b6:b10", "d2:d8").Select '选中包含两个单元格区域的最小矩形区域  
End Sub  
  
  
Sub cel()  
  ActiveSheet.Cells(3, 4).Value = 20  '在第3行与第4列的相交的单元格输入20  
End Sub  
Sub cel()  
  ActiveSheet.Cells(3, "D").Value = 20  '在第3行与D列的相交的单元格输入20  
End Sub  
Sub cel()  
  Range("b3:f9").Cells(2, 3) = 100 '在b3:f9单元格区域的第2行与第3行相交的单元格  
End Sub  
  
Range(Cells(1, 1), Cells(10, 5)).Select   '选中活动工作表的A1：E10单元格  
Range("A1", "E10").Select   '选中活动工作表的A1：E10单元格  
Range(Range("A1"), Range("E10")).Select   '选中活动工作表的A1：E10单元格  
  
Sub cel()  
  ActiveSheet.Cells(2).Value = 200  '在活动工作表的第2个单元格输入200  
End Sub  
Sub cel()  
  Range("b3:f9").Cells(8).Value = 100  '在b3:f9的第8个单元格输入100  
End Sub  
Sub cel()  
  ActiveSheet.Cells.Select        '选中活动工作表中的所有单元格  
  Range("b3:f9").Cells.Select     '选中活动工作表中的b3:f9单元格区域  
End Sub  
  
ActiveSheet.Rows("3:3").Select     '选中活动工作表的第3行  
ActiveSheet.Rows("3:5").Select     '选中活动工作表的第3行到第5行  
ActiveSheet.Rows(3).Select         '选中活动工作表的第3行  
ActiveSheet.Rows.Select            '选中活动工作表的所有行  
Rows("3:10").Rows("1:1").Select    '选中第3行到第10行区域中的第1行  
  
ActiveSheet.Columns ("f:g")        '选中活动工作表中的F至G列  
ActiveSheet.Columns (6)            '选中活动工作表中的第6列  
ActiveSheet.Columns                '选中活动工作表中的所有列  
Columns("B:G").Columns("B:B").Select  '选中B:G列区域中的第2列  
  
Sub rngunion()  
  '同时选中两个单元格区域  
  Application.Union(Range("A1:A10"), Range("D1:D5")).Select  
End Sub  
  
Sub uniontest()                     '声明过程名  
  Dim myrange As Range, n As Range  '定义两个range变量  
  Set myrange = Range("A1")         '为变量myrange赋值  
  For Each n In Range("A1:D10")     '遍历A1：D10区域  
    If n.Value = Range("A1").Value Then  '判断range变量n的内容是否等于A1单元格的内容  
    Set myrange = Union(myrange, n) '将range变量n指代的单元格添加进myrange变量中  
    End If                          'if语句结束  
  Next                              '回到FOR语句开始处  
  myrang.Select                     '选中myrange代表的单元格  
End Sub                             '结束过程  
  
Range("A1").Offset(2, 3).Value = 500  '第一个参数2告诉VBA向下移动2行，第二个参数3告诉VBA向右移动3列  
Range("C5:D6").Offset(-3, 0).Select   '第一个参数-3告诉VBA向上移动3行，第二个参数0告诉VBA列方向上不移动  
Range("b2").Resize(5, 4).Select       '将B2单元格扩大为B2：E6  
Range("B2:E6").Resize(2, 1).Select    '将B2:E6单元格区域缩小为B2：B3  
  
ActiveSheet.UsedRange.Select       '选中活动工作表中已使用的单元格区域  
  
Range("B5").CurrentRegion.Select   '相当于选中B5单元格后按F5，定位“当前区域”得到的单元格区域  
  
Range("C5").End(xlUp).Select       '参数xlup告诉VBA，移动的方向是向上，等同于在C5单元格按<end + 上方向键>得到的单元格  
  
xlToLeft            '向左移动，等同于在源单元格按<Ctrl + 左方向键>  
xlToRight           '向右移动，等同于在源单元格按<Ctrl + 右方向键>  
xlUp                '向上移动，等同于在源单元格按<Ctrl + 上方向键>  
xlDown              '向下移动，等同于在源单元格按<Ctrl + 下方向键>  
  
ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Value = "张青"    '在A列A65536个单元格开始往上按方向键得到A列最后一个非空单元格，往下移动一行，在里面输入“张青”  
  
Range("A1:B2").Value = "abc"           '在A1：B2输入abc  
Range("B1").Value = Range("A1").Value  '把A1的内容写入B1  
Range("A1:B2") = "abc"                 '在A1：B2输入abc，不建议这样写程序  
  
ActiveSheet.UsedRange.Rows.Count         '求活动工作表中已使用的行数  
ActiveSheet.UsedRange.Columns.Count      '求活动工作表中已使用的行数  
  
MsgBox "当前选中的单元格地址为：" & Selection.Address  
  
ActiveSheet.Range("A1:B10").Select  
ActiveSheet.Range("A1:B10").Activate  
'上面两句代码都是等效的，无论那种方法，选中单元格前，单元格所在的工作表都必须是活动工作表。  
  
Range("B2:B15").Clear           '清除B2：B15单元格所有包括批注、内容、注释、格式等内容  
Range("B2:B15").ClearComments   '清除B2：B15单元格的批注  
Range("B2:B15").ClearContents   '清除B2：B15单元格的内容  
Range("B2:B15").ClearFormats    '清除B2：B15单元格的格式  
  
Range("A1").Copy Range("C1")               '复制A1到C1  
Range("A1").Copy Destination:=Range("C1")  '复制A1到C1,Destination:= 可以省略  
  
Range("A1").CurrentRegion.Copy Range("G1")      '复制不确定大小的区域，指定左上角的单元格  
Range("F1:I10").Value = Range("A1:D10").Value   '仅仅复制内容  
  
Range("B5").Delete shift:=xlToLeft       '删除B5单元格，删除后右侧单元格左移  
Range("B5").Delete shift:=xlUp           '删除B5单元格，删除后下方单元格上移 = Range("B5").Delete  
Range("B5").EntireRow.Delete             '删除B5单元格所在的行  
Range("B5").EntireColumn.Delete          '删除B5单元格所在的列  
  
'定义名称  
ActiveWorkbook.Names.Add Name:="date", RefersToR1C1:="=Sheet1!R5C\[-2\]"   'R5表示第5行C\[-2\]表示活动单元格左边第2列  
ActiveWorkbook.Names.Add Name:="date", RefersTo:="=Sheet1!$B$4"         '如果不加$，则使用相对引用，将把活动单元格当做A1单元格  
Range("A1:C10").Name = "date"  
  
'引用名称  
ActiveWorkbook.Names("date").Name = "姓名"              '更改名称名  
ActiveWorkbook.Names("姓名").RefersTo = "张万平"        '更改名称的值  
  
Sub usename\_2()  
  Dim i As Integer, mx As Integer  
  mx = ActiveWorkbook.Name.Count                   '统计一共有多少个名称  
  For i = 1 To mx  
    ActiveWorkbook.Name (i), Visible = False       '隐藏名称  
  Next  
End Sub  
  
Range("B5").AddComment Text:="我用VBA新建的批注"  
  
Sub com()  
  If Range("B5").Comment Is Nothing Then    '判断是否存在comment对象  
    msgbox "B5单元格中没有批注！"  
  Else  
    msgbox "B5单元格中已有批注！"  
  End If  
End Sub  
  
Sub com()  
  Range("B5").Comment.Text = "更改批注的内容"   '更改批注的内容  
  Range("B5").Comment.Visible = False           '隐藏批注  
  Range("B5").Comment.Delete                    '删除批注  
End Sub  
  
Font 对象  
Sub FontSet()  
    With Range("A1:L1").Font  
        .Name = "宋体"                           '设置字体为宋体  
        .Size = 12                               '设置字号为12  
        .Color = RGB(255, 0, 0)                  '设置字体颜色为红色  
        .Bold = True                             '设置字体加粗  
        .Italic = True                           '设置文字倾斜显示体  
        .Underline = xlUnderlineStyleDouble      '给文字添加双下划线  
    End With  
End Sub  
  
Range("A1:L1").Interior.Color = RGB(255, 255, 0) '添加黄色底纹  
  
Sub BorderSet()  
    With Range("A1").CurrentRegion.Borders  
        .LineStyle = xlContinuous                 '设置单线边框  
        .Color = RGB(0, 0, 255)                   '设置边框的颜色  
        .Weight = xlHairline                      '设置边框线条样式  
    End With  
End Sub  
  
  
Sub WbAdd()  
    '程序创建“员工花名册”工作簿，保存在本工作簿所在的文件夹中。  
    Dim wb As Workbook, sht As Worksheet     '定义一个workbook对象和一个worksheet对象  
    Set wb = Workbooks.Add                   '新建一个工作簿  
    Set sht = wb.Worksheets(1)  
    With sht  
        .Name = "花名册"                     '修改第一张工作表的标签名称  
        '设置表头  
        .Range("A1:F1") = Array("序号", "姓名", "性别", "出生年月", "参加工作时间", "备注")  
    End With  
    wb.SaveAs ThisWorkbook.Path & "\\员工花名册.xls" '保存新建的工作表到本工作簿所在的文件夹中  
    ActiveWorkbook.Close                            '关闭新建的工作簿  
End Sub  
  
  
Sub IsOpen()  
    '判断“成绩表.xls”工作簿文件是否打开。  
    Dim i As Integer                             '定义循环变量  
    For i = 1 To Workbooks.Count                 '开始循环  
        If Workbooks(i).Name = "成绩表.xls" Then '判断工作簿是否打开  
            MsgBox "文件已打开！"  
            Exit Sub                              '如果找到该文件，退出过程  
        End If  
    Next  
    MsgBox "文件没有打开！"  
End Sub  
  
Sub TestFile()  
    '判断本工作簿所在的文件夹中是否存在“员工花名册.xls”  
    Dim fil As String                           '定义变量  
    fil = ThisWorkbook.Path & "\\员工花名册.xls"  
    If Len(Dir(fil)) > 0 Then                   '用dir判断fil指代的文件是否存在  
        MsgBox "工作簿已存在！"  
    Else  
        MsgBox "工作簿不存在！"  
    End If  
End Sub  
  
Sub WbInput()  
    '在本工作簿所在的文件夹下“员工花名册”里添加一条记录！  
    Dim wb As String, xrow As integere, arr  
    wb = ThisWorkbook.Path & "\\员工花名册.xls"              '指定要打开的文件  
    Workbooks.Open (wb)                                     '打开工作簿  
    With ActiveWorkbook.Worksheets(1)                       '向工作簿里的第1张工作表里添加记录  
        xrow = .Range("A1").CurrentRegion.Rows.Count + 1    '取得表格中第一条空行号  
        '将需要增加的职工信息保存在数组arr里  
        arr = Array(xrow - 1, "张娇", "女", \#7/8/1987\#, \#9/1/2010\#, "10年新招")  
        .Cells(xrow, 1).Resize(1, 6) = arr                  '将数组写入单元格区域  
    End With  
    ActiveWorkbook.Close savechanges:=True                  '关闭工作簿，并保存修改  
End Sub  
  
Sub ShtVisible()  
    '隐藏活动工作表外的所有工作表！  
    Dim sht As Worksheet                    '定义一个worksheet变量  
    For Each sht In Worksheets              '遍历所有工作表  
        If sht.Name <> ActiveSheet.Name Then  
            sht.Visible = xlSheetVeryHidden '深度隐藏工作表  
        End If  
    Next  
End Sub  
  
Sub ShtAdd()  
    '根据C列的班级名新建不同的工作表  
    Dim i As Integer, sht As Worksheet  
    i = 2                                                   '第一条记录的行号为2  
    Set sht = Worksheets("成绩表")  
    Do While sht.Cells(i, "C") <> ""                        '定义循环条件  
        Worksheets.Add after:=Worksheets(Worksheets, Count) '在所有工作表后插入新工作表  
        ActiveSheet.Name = sht.Cells(i, "C").Value          '更改工作表的标签名称  
        i = i + 1                                           '行号增加1  
    Loop  
End Sub  
  
  
Sub ShtAdd\_1()  
    '根据C列的班级名新建不同的工作表，C列存在重复名称  
    Dim i As Integer, sht As Worksheet  
    i = 2                                                        '第一条记录的行号为2  
    Set sht = Worksheets("成绩表")  
    Do While sht.Cells(i, "C").Value <> ""                       '定义循环条件  
        On Error Resume Next                                     '当没有对应班级工作表时，忽略下一行代码引起的运行时的错误  
        If Worksheets(sht.Cells(i, "C").Value) Is Nothing Then   '判断是否存在对应的班级工作表  
        Worksheets.Add after:=Worksheets(Worksheets, Count)      '在所有工作表后插入新工作表  
        ActiveSheet.Name = sht.Cells(i, "C").Value               '更改工作表的标签名称  
        End If  
        i = i + 1                                                '行号增加1  
    Loop  
End Sub  
  
Sub FenLei()  
    '把成绩表按班级分别各个工作表中  
    Dim i As Long, bj As String, rng As Range  
    i = 2  
    bj = Cells(i, "C").Value  
    Do While bj <> ""  
        '将分表中A列第一个空单元格赋给rng  
        Set rng = Worksheets(bj).Range("A65536").End(xlUp).Offset(1, 0)  
        Cells(1, "A").Resize(1, 7).Copy rng '将记录复制到相应的工作表中  
        i = i + 1  
        bj = Cells(i, "C").Value  
    Loop  
End Sub  
  
Sub ShtClear()  
    Dim sht As Worksheet  
    For Each sht In Worksheets  
        If sht.Name <> "成绩表" Then           '"成绩表"为保存源数据记录的工作表标签名称  
        sht.Range("A2:G65536").ClearContents   '清除各分表中的数据记录  
        End If  
    Next  
End Sub  
  
Sub SaveToFile()  
    '把各个工作表以单独的工作簿文件保存在本工作簿所在文件夹下的“班级成绩表”文件夹中  
    Application.ScreenUpdating = False                             '关闭屏幕更新  
    Dim folder As String  
    folder = ThisWorkbook.Path & "\\班级成绩表"  
    '如果文件不存在，新建文件夹  
    If Len(Dir(folder, vbDirectory)) = 0 Then mkder folder  
    Dim sht As Worksheet  
    For Each sht In Worksheets                                     '遍历工作表  
        .sht.Copy                                                  '复制工作表到新工作簿  
        ActiveWorkbook.SaveAs folder & "\\" & sht.Name & ".xls"     '保存工作簿，并命名  
        ActiveWorkbook.Close  
    Next  
    Application.ScreenUpdating = True                              '开启屏幕更新  
End Sub  
  
  
Sub hebing()  
    '把各班成绩表合并到“总成绩”工作表中  
    Rows("2:65536").Clear                                       '删除原有记录  
    Dim sht As Worksheet, xrow As Integer, rng As Range  
    For Each sht In Worksheets                                  '遍历工作簿中所有工作表  
        If sht.Name <> ActiveSheet.Name Then  
            Set rng = Range("A65536").End(xlUp).Offset(1, 0)    '获得A列第一个空单元格  
            xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1 '获得分表中的记录条数  
            sht.Range("A2").Resize(xrow, 7).Copy rng            '粘贴记录到汇总表  
        End If  
    Next  
End Sub  
  
  
Sub HzwWb()  
    Dim r As Long, c As Long  
    r = 1            '1是表头的行数  
    c = 8            '8是表头的列数  
    Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents     '清除汇总表中原表数据  
    Application.ScreenUpdating = False  
    Dim filename As String, wb As Workbook, sht As Worksheet, erow As Long, fn As String, arr As Variant  
    filename = Dir(ThisWorkbook.Path & "\\\*.xls")  
    Do While filename <> ""  
        If filename <> ThisWorkbook.Name Then                   '判断文件是否是本工作簿  
            erow = Range("A1").CurrentRegion.Rows.Count + 1     '取得汇总表中第一条空行行号  
            fn = ThisWorkbook.Path & "\\" & filename  
            Set wb = getboject(fn)                              '将fn代表的工作簿对象赋给变量  
            Set sht = wb.Worksheets(1)                          '汇总的是第一张工作表  
            '将数据表中的记录保存在arr数组里  
            arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 8))  
            '将数组arr中的数据写入工作表  
            Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr  
            wb.Close False  
        End If  
        filename = Dir                '用dir函数取得其他文件名，并赋给变量  
    Loop  
    Application.ScreenUpdating = True  
End Sub  
  
Sub mulu()  
    '为工作簿中所有工作表建立目录  
    Rows("2:65536").ClearContents                             '清除工作表中原表数据  
    Dim sht As Worksheet, irow As Integer  
    irow = 2                                                  '在第2行写入第一条记录  
    For Each sht In Worksheets                                '遍历工作表  
        Cells(irow, "A").Value = irow - 1                     '写入序号  
        '写入工作表名，并建立超链接  
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(irow, "B"), Address:="", SubAddress:="'" & sht.Name & "'!A1", TextToDisplay:=sht.Name  
        irow = irow + 1                                       '行号加1  
    Next  
End Sub  
  
Private Sub workbook\_open()  
    '每次打开工作簿时都会自动执行下面的程序  
    MsgBox "你好，祝你工作愉快！"  
End Sub  
  
Private Sub workbook\_change(ByVal target As Range)  
    '更改任意单元格值会运行程序  
    MsgBox target.Address & "单元格的值被更改为：" & target.Value  
End Sub  
  
Private Sub workbook\_change(ByVal target As Range)  
    If target.Column = 1 Then       '判断更改的单元格是否为A列单元格  
        MsgBox target.Address & "单元格的值被更改为：" & target.Value  
    End If  
End Sub  
  
Private Sub workbook\_change(ByVal target As Range)  
    Application.EnableEvents = False      '禁用事件  
    target.Value = "新内容：" & target.Value  
    Application.EnableEvents = True       '启用事件  
End Sub  
  
Private Sub workbook\_selectionchange(ByVal target As Range)       'target是程序运行的参数，代表新选中的单元格区域  
    MsgBox "当前选中的单元格区域为：" & target.Address  
End Sub  
  
Private Sub Worksheet\_Activate()  
    MsgBox "当前活动工作表为：" & ActiveSheet.Name  
End Sub  
  
Private Sub Worksheet\_Deactivate()  
    MsgBox "不允许选中sheet1工作表外的其他工作表！"  
    Workssheets("Sheet1").Select  
End Sub  
  
Activate     '激活工作表时发生  
BeforeDoubleClick    '双击工作表之后，默认的双击操作之前发生  
BeforeRightClick     '右击工作表之后，默认的右击操作之前发生  
Calculate            '重新计算工作表之后发生  
Change               '工作表中的单元格发生更改时发生  
Deactivate           '工作表由活动工作表变为不活动工作表时发生  
FollowHyperlink      '单击工作表中的任意超链接时发生  
PivotTableUpdate     '在工作表中更新数据透视表之后发生  
SelectionChange      '工作表中所选内容发生更改时发生  
  
'Workbook\_Open事件告诉EXCEL，当打开工作簿时自动运行程序  
Private Sub Workbook\_BeforeClose(cancel As Boolean)  
    If MsgBox("你确定要关闭工作簿吗？", vbYesNo) = vbNo Then  
        cancel = True   '取消关闭  
    End If  
End Sub  
  
Private Sub Workbook\_SheetChange(ByVal Sh As boject, ByVal target As Range)  
    MsgBox "当前更改的工作表为：" & Sh.Name & Chr(13) & "发生更改的单元格地址为：" & target.Address  
End Sub  
  
Activate     '当激活工作簿时发生  
AddinInstall '当工作簿作为加载宏安装时发生  
AddinUninstall  '当工作簿作为加载宏卸载时发生  
AfterXmlExport  '在保存或导出指定工作簿中的xml数据之后发生  
AfterXmlImport  '在刷新现有xml数据连接或新的xml数据被导入任意一个打开的工作簿后发生  
BeforeClose     '在关闭工作簿之前发生。如果工作簿已更改，则此事件在询问用户是否保存更改之前发生  
BeforePrint     '在打印指定工作簿（或其中任何内容）之前发生  
BeforeSave      '在保存工作簿前发生  
BeforeXmlExport '在保存或导出指定工作簿中的xml数据之前发生  
BeforeXmlImport '在刷新现有xml数据连接或新的xml数据被导入任意一个打开的工作簿前发生  
Deactivate      '在工作簿从活动状态转为非活动状态时发生  
NewSheet        '在工作簿中新建工作表是发生  
Open            '在打开工作簿时发生  
PivotTableCloseConnection  '在数据透视表的连接关闭之后发生  
PivotTableOpenConnection   '在数据透视表的连接打开之后发生  
SheetActivate              '激活任意工作表时发生  
SheetBeforeDoubleClick     '双击任意工作表时（默认的双击操作之前）发生  
SheetBeforeRightClick      '右击任意工作表时（默认的右击操作之前）发生  
SheetCalculate             '在重新计算工作表时或在图表上绘制更改的数据之后发生  
SheetChange                '当更改任何工作表中的单元格时发生  
SheetDeactivate            '工作表由活动工作表变为不活动工作表时发生  
SheetFollowHyperlink       '当单击工作表中的任意超链接时发生  
SheetPivotTableUpdate      '在更新数据透视表的工作表之后发生  
SheetSelectionChange       '当任意工作表上的选定区域发生更改时发生（但图表工作表上的选定区域发生改变时，不会发生此事件）  
Sync             '当作为“文档工作区”一部分的工作簿的本地副本与服务器上的副本进行同步时发生  
WindowActivate   '在激活任意工作簿窗口时发生  
WindowDeactivate '当任意工作簿窗口由活动窗口变为不活动窗口时发生  
WindowResize     '在调整任意工作簿窗口大小时发生  
  
  
Private Sub cmd\_MouseMove(ByVal Button As Integer, ByVal shift As Integer, ByVal x As Single, ByVal Y As Single)  
'MouseMove事件告诉EXCEL，当鼠标指针在CMD按钮上移动时自动运行程序  
    Dim l As Integer, t As Integer  
    l = Int(Rnd() \* 10 + 125) \* (Int(Rnd() \* 3 + 1) - 2) '生成随机数  
    t = Int(Rnd() \* 10 + 30) \* (Int(Rnd() \* 3 + 1) - 2) '生成随机数  
    cmd.Top = cmd.Top + t  '重新设置改按钮的top属性值  
    cmd.Left = cmd.Left + l '重新设置改按钮的left属性值  
End Sub  
  
Private Sub Back\_Click()  
'Click告诉EXCEL，当单击按钮时，自动运行程序  
    cmd.Top = 15   '设置cmd按钮的top属性为15  
    cmd.Left = 160 '设置cmd按钮的left属性为160  
End Sub  
  
Sub ok()  
    Application.OnKey "+e", "test"   '当按下shift+e组合键时，运行test过程  
End Sub  
  
Sub test()  
    MsgBox "你好，我在学习onkey方法！"  
End Sub  
  
Sub oT()  
    '一个小时后，自动运行Test过程  
    Application.OnTime Now() + TimeValue("01:00:00"), "Test"  
End Sub  
  
  
Private Sub Worksheet\_Change(ByVal target As Range)  
'如果更改的单元格不是C列第3行一下的单元格或更改的单元格个数大于1时退出程序  
    If Application.Intersect(target, Range("c3:c65536")) Is Nothing Or target.Count > 1 Then  
        Exit Sub  
    End If  
    Dim i As Integer  
    i = 3  
    Do While Cells(i, "I").Value <> ""  
    '判断录入的字母与参照表的字母是否相符  
        If UCase(target.Value) = Cells(i, "I").Value Then  
            Application.EnableEvents = False   '禁用事件，防止将字母改为商品名称时，再次执行程序  
            target.Value = Cells(i, "I").Offset(0, 1).Value      '写入产品名称  
            target.Offset(0, -1).Value = Date                    '写入销售日期  
            target.Offset(0, 1).Value = Cells(i, "I").Offset(0, 2).Value '写入商品代码  
            target.Offset(0, 2).Value = Cells(i, "I").Offset(0, 3).Value '写入商品单价  
            target.Offset(0, 3).Select                    '选中销售数量列，等待输入销售数量  
            Application.EnableEvents = True               '重新启用事件  
            Exit Sub  
        End If  
        i = i + 1  
    Loop  
End Sub  
  
Private Sub worksheet\_selectionchange(ByVal target As Range)  
    Range("b3:q22").Interior.ColorIndex = xlNone  '清除单元格里原有底纹颜色  
    '当选中的单元格个数大于1时，重新给Traget赋值  
    If target.Count > 1 Then  
        Set target = target.Cells(1)  
    End If  
    '当选中的单元格不包含指定区域的单元格时，退出程序  
    If Application.Intersect(target, Range("b3:q22")) Is Nothing Then  
        Exit Sub  
    End If  
    Dim rng As Range  
    '遍历单元格  
    For Each rng In Range("b3:q22")  
        If rng.Value = target.Value Then  
            rng.Interior.ColorIndex = 39  
        End If  
    Next  
End Sub  
  
Private Sub worksheet\_selectionchange(ByVal target As Range)  
    Range("b3:q22").Interior.ColorIndex = xlNone  '清除单元格里原有底纹颜色  
    '当选中的单元格个数大于1时，重新给Traget赋值  
    If target.Count > 1 Then  
        Set target = target.Cells(1)  
    End If  
    '当选中的单元格不包含指定区域的单元格时，退出程序  
    If Application.Intersect(target, Range("b3:q22")) Is Nothing Then  
        Exit Sub  
    End If  
    Dim rng As Range  
    '添加底纹颜色  
    Range(Cells(target.Row, "B"), Cells(target.Row, "Q")).Interior.ColorIndex = 39  
    Range(Cells(3, target.Column), Cells(22, target.Column)).Interior.ColorIndex = 39  
End Sub  
  
Sub otime()  
    '一分钟后自动运行wbsave过程  
    Application.OnTime Now() + TimeValue("00:01:00"), "wbsave"  
End Sub  
  
Sub wbsave()  
    ThisWorkbook.Save     '保存工作簿  
    Call otime             '再次运行otime过程  
End Sub  
  
Private Sub workbook\_open()  
    Call otime        '打开工作簿后自动运行otime过程  
End Sub  
  
Private Sub xb1\_chick()  
    If xb1.Value = True Then         '如果xb1已选中则执行if与end if之间的代码  
        Range("f2").Value = "男"     '在F2单元格里输入“男”  
        xb2.Value = False            '更改xb2为未选中状态  
    End If  
End Sub  
  
Private Sub xb2\_chick()  
    If xb2.Value = True Then         '如果xb2已选中则执行if与end if之间的代码  
        Range("f2").Value = "女"     '在F2单元格里输入“女”  
        xb1.Value = False            '更改xb1为未选中状态  
    End If  
End Sub  
  
Sub inbox()  'inputbox函数  
    Dim str As String  
    '将输入的值赋给变量str  
    str = InputBox(prompt:="请输入姓名", Title:="操作提示", Default:="张娇", xpos:=2000, ypos:=2500) 'prompt是对话框上的提示文字，title是对话框的标题，default是默认输入值如果省  
  
略则为空，xpos是对话框的左端与屏幕左端的距离，ypos是对话框的顶端与屏幕顶端的距离  
    Range("A1") = str '将输入的值写入A1单元格  
End Sub  
'除了prompt其他都可以省略  
  
str = InputBox("请输入姓名：")  
str = InputBox(prompt:="请输入姓名：")  
str = InputBox(prompt:="请输入姓名：", Default:="张三")  
str = InputBox("请输入姓名：", , "张三")  
  
Sub appinbox()   'inputbox 方法  
    Dim str As String  
    '将输入的值赋给变量str  
    str = Application.InputBox(prompt:="请输入姓名：", Title:="操作提示", Default:="张娇", Left:=100, Top:=100)    'left = xpos,top = ypos  
    Range("A1") = str  '将输入的值写入A1单元格  
End Sub  
'inputbox函数创建的对话框只能返回string类型的字符串；inputbox方法多一个type参数，返回的数据类型不确定。  
'多出来的type参数说明：0 = 公式； 1 = 数字； 2 = 文本(字符串)； 4 = 逻辑值（True或False）； 8 = 单元格引用（Range对象）； 16 = 错误值，如\#N/A； 64 = 数值数组  
  
Sub rnginput()  
    Dim rng As Range        '定义一个range对象  
    On Error GoTo cancel    '如果单击“取消”按钮，出现错误，跳转到cancel处  
    '将选中的单元格对象赋给变量rng  
    Set rng = Application.InputBox(prompt:="请选择需要输入数值的单元格区域", Type:=8)  
    rng.Value = 100   '在选中的单元格输入100  
cancel:  
End Sub  
  
Application.InputBox(prompt:="请输入内容：", Type:=1 + 2) = Application.InputBox(prompt:="请输入内容：", Type:=3) '1表示数字，2表示文本，1+2表示数字和文本任意一种都可以，也可以  
  
写3,3也是表示数字和文本任意一种  
  
Sub msg()  
    MsgBox prompt:="中午十二点，该吃午饭了！", Buttons:=vbOKOnly + vbInformation, Title:="温馨提醒"  'prompt是对话框中要显示的文本信息，Buttons指定对话框中显示的按钮数目。按钮形  
  
式、使用的图标样式、缺省按钮以及消息框的强制回应，title指定在对话框的标题栏中显示的  
End Sub  
  
'msgbox的6种按钮设定  
'vbOkonly               0       只显示【确定】按钮  
'vbOkCancel             1       显示【确定】和【取消】2个按钮  
'vbAbortRetryIgonre     2       显示【终止】、【重试】和【忽略】3个按钮  
'vbYesNoCancel          3       显示【是】、【否】和【取消】3个按钮  
'vbYesNo                4       显示【是】和【否】2个按钮  
'vbRetryCancel          5       显示【重试】和【取消】2个按钮  
  
Sub msgbut()  
    MsgBox prompt:="只显示【确定】按钮", Buttons:=vbOKOnly  
    MsgBox prompt:="显示【确定】和【取消】2个按钮", Buttons:=vbOKCancel  
    MsgBox prompt:="显示【终止】、【重试】和【忽略】3个按钮", Buttons:=vbAbortRetryIgonre  
    MsgBox prompt:="显示【是】、【否】和【取消】3个按钮", Buttons:=vbYesNoCancel  
    MsgBox prompt:="显示【是】和【否】2个按钮", Buttons:=vbYesNo  
    MsgBox prompt:="显示【重试】和【取消】2个按钮", Buttons:=vbRetryCancel  
End Sub  
  
Sub msgbut()  
    MsgBox prompt:="显示“关键消息”图标", Buttons:=vbCritical               'vbCritical       16       显示“关键消息”图标  
    MsgBox prompt:="显示“警告询问”图标", Buttons:=vbQuestion               'vbQuestion       32       显示“警告询问”图标  
    MsgBox prompt:="显示“警告消息”图标", Buttons:=vbExclamation            'vbExclamation    48       显示“警告消息”图标  
    MsgBox prompt:="显示“通知消息”图标", Buttons:=vbInformation            'vbInformation    64       显示“通知消息”图标  
End Sub  
  
Sub msgbut()  
    Dim yn As Integer  
    yn = MsgBox(prompt:="是否在A1单元格输入100？", Buttons:=vbYesNo + vbQuestion)  
    If yn = vbYes Then         '判断用户按下哪个按钮  
        Range("A1").Value = 100  
    End If  
End Sub  
  
yn = MsgBox(prompt:="是否在A1单元格输入100？", Buttons:=vbYesNo + vbQuestion + vbDefaultButton2)     'vbDefaultButton2 设置第二个按钮为缺省按钮，参数值也可以写为4+32+256或者292  
  
'vbDefaultButton1           0              第一个按钮为缺省按钮  
'vbDefaultButton2          256             第二个按钮为缺省按钮  
'vbDefaultButton3          512             第三个按钮为缺省按钮  
'vbDefaultButton4          768             第四个按钮为缺省按钮  
  
'vbApplicationModal          0        应用程序强制返回；暂停执行应用程序，直到用户对消息框做出响应才继续工作  
'vbSystemModal             4096       系统强制返回；暂停执行应用程序，直到用户对消息框做出响应才继续工作  
  
'msgbox函数的返回值  
'vbOK        1       单击【确定】按钮  
'vbCancel    2       单击【取消】按钮  
'vbAbort     3       单击【终止】按钮  
'vbRetry     4       单击【重试】按钮  
'vbIgnore    5       单击【忽略】按钮  
'vbYes       6       单击【是】按钮  
'vbNo        7       单击【否】按钮  
  
Sub openfile()  
    If Application.FindFile = True Then    '判断文件是否打开  
        MsgBox "选择的文件已打开！"  
    Else  
        MsgBox "没有打开任何文件！"  
    End If  
End Sub  
  
Sub getfile\_1()  
    Dim fil As String  
    fil = Application.GetOpenFilename()   '将选中的文件名赋给变量fil  
    If fil = "False" Then  
        MsgBox "没有选择任何文件！"  
        Exit Sub                         '退出程序  
    Else  
        Range("a1").Value = fil          '将文件名写入活动工作表的A1单元格  
    End If  
End Sub  
  
Sub getfile()  
    Dim fil As String  
    fil = Application.GetOpenFilename(filefilter:="Excel 97-2003 工作簿(\*.xls),\*.xls")  'Excel 97-2003 工作簿(\*.xls)是文件筛选条件，\*.xls指定在对话框中显示的文件类型  
    Range("A1").Value = fil      '将文件名写入A1单元格  
End Sub  
  
Sub getfile\_3()  
    Dim fil As String  
    fil = Application.GetOpenFilename(filefilter:="Excel或Word 97-2003 文件(\*.xls;\*.doc),\*.xls;\*.doc")  
    Range("A1").Value = fil      '将文件名写入A1单元格  
End Sub  
  
fil = Application.GetOpenFilename(filefilter:="Excel 97-2003 工作簿(\*.xls),\*.xls,Word 97-2003 文档(\*.doc),\*.doc")  
  
Sub getfile4()  
    Dim fil  
    fil = Application.GetOpenFilename(filefilter:="Excel 97-2003 工作簿(\*.xls),\*.xls,Word 97-2003 文档(\*.doc),\*.doc", FilterIndex:=2, Title:="请选择文件", MultiSelect:=True)  
    \[A1\].Resize(UBound(fil), 1) = Application.WorksheetFunction.Transpose(fil)  
End Sub  
  
Sub getsaveas()  
    Dim fil As String, filename As String, filter As String, tle As String  
    filename = "我要选择的文件"  
    filter = "Excel 97-2003 工作簿(\*.xls),\*.xls,Word 97-2003 文档(\*.doc),\*.doc,文本文件(\*.txt),\*.txt"  
    tle = "请选择需要的文件"  
    '用变量做方法的参数  
    fil = Application.GetSaveAsFilename(InitialFileName:=filename, filefilter:=filter, FilterIndex:=2, Title:=tle)  'InitialFileName指定显示的文件名，filefilter指定文件的筛选条  
  
件，FilterIndex设置【保存类型】下拉列表中的第几项默认筛选条件，Title指定对话框的标题  
    Range("A1") = fil '把文件名写入A1单元格  
End Sub  
  
Sub getfolder()  
    With Application.FileDialog(filedialogtype:=msoFileDialogFolderPicker)   'msoFileDialogFolderPicker参数只允许用户选择一个文件夹  
        .InitialFileName = "D:\\"         '设置D盘根目录为起始目录  
        .Title = "请选择一个目录"        '设置对话框标题  
        .Show                            '显示对话框  
        If .SelectedItems.Count > 0 Then '判断是否选中了目录  
            Range("A1").Value = .SelectedItems(1) '将选中的目录名及路径写进A1单元格  
        End If  
    End With  
End Sub  
'msoFileDialogFilePicker     允许选择一个文件  
'msoFileDialogFolderPicker   允许选择一个文件夹  
'msoFileDialogOpen           允许打开一个文件  
'msoFileDialogSaveAs         允许保存一个文件  
  
Sub xianshi()  
    Load 录入    '加载“录入”窗体  
    录入.Show    '显示“录入”窗体  
End Sub  
  
Sub xianshi()  
    录入.Show    '显示名称为“录入”的窗体  
End Sub  
  
Sub xianshi()  
    录入.Show vbModal   '显示模式窗体  
    Range("A1") = "现在显示的是模式窗体！"  
End Sub  
  
Sub hidefrom()  
    录入.Hide       '隐藏“录入”窗体  
End Sub  
  
Sub unloadfrom()  
    Unload 录入       '卸载“录入”窗体  
End Sub  
  
Private Sub userform\_initialize()  
    '设置性别复合框的条目为“男”和“女”  
    性别.List = Array("男", "女")  
End Sub  
  
Private Sub 确定\_click()  
'判断信息是否输入完整  
    If 姓名.Value = "" Or 性别.Value = "" Or 出生年月.Value = "" Then  
        MsgBox "信息输入不完整，请重新输入！", vbExclamation, "错误提示"  
        Exit Sub                                                            '退出执行程序  
    End If  
    Dim xrow As Integer  
    xrow = Range("A1").CurrentRegion.Rows.Count + 1 '求第一条空行行号  
    '将姓名、性别、出生年月写入第一条空行  
    Cells(xrow, "A") = 姓名.Value  
    Cells(xrow, "B") = 性别.Value  
    Cells(xrow, "C") = 出生年月.Value  
    '内容写入工作表后，将控件中的内容消除  
    姓名.Value = ""  
    性别.Value = ""  
    出生年月.Value = ""  
End Sub  
  
Private Sub 退出\_click()  
    Unload Me   '卸载录入窗体  me指录入窗体，即代码所在的模块  
End Sub  
  
Application.Caption = "我的程序"   '更改标题栏程序名称为“我的程序”  
  
Sub menuhide()  
    With Application.CommandBars(1)  
        .Controls("文件(&F)").Visible = False    '隐藏“文件”菜单  
        .Controls("编辑(&E)").Visible = False    '隐藏“编辑”菜单  
        .Controls("视图(&V)").Visible = False    '隐藏“视图”菜单  
        .Controls("插入(&I)").Visible = False    '隐藏“插入”菜单  
        .Controls("格式(&O)").Visible = False    '隐藏“格式”菜单  
        .Controls("工具(&T)").Visible = False    '隐藏“工具”菜单  
        .Controls("数据(&D)").Visible = False    '隐藏“数据”菜单  
        .Controls("窗口(&W)").Visible = False    '隐藏“窗口”菜单  
        .Controls("帮助(&H)").Visible = False    '隐藏“帮助”菜单  
    End With  
End Sub  
  
Sub menuhide()  
    Dim i%  '定义一个变量  
    With Application.CommandBars(1)  
        For i = 1 To .Controls.Count  
            .Controls(i).Visible = False  '隐藏第i个菜单  
        Next  
    End With  
End Sub  
  
Sub menuhide()  
    Application.CommandBars(1).Enabled = False   '隐藏菜单栏  
End Sub  
  
Sub toolhide()  
    '隐藏常用工具栏和格式工具栏  
    With Application  
        .CommandBars("standard").Visible = False       '隐藏常用工具栏  
        .CommandBars("formatting").Visible = False     '隐藏格式工具栏  
    End With  
End Sub  
  
Sub toolhide()  
    Dim i%  
    For i = 2 To Application.CommandBars.Count     '索引号从2开始，因为1是菜单栏  
        Application.CommandBars (i), Enabled = False '隐藏所有工具栏  enabled，利用索引号引用对象，并设置对象的enabled属性值为false，如果想重新显示工具栏，将属性值设回true即可  
    Next  
End Sub  
  
Sub windowset()  
    With ActiveWindow  
        .DisplayHeadings = False                 '隐藏行标和列标  
        .DisplayHorizontalScrollBar = False      '隐藏行标和列标  
        .DisplayVerticalScrollBar = False        '隐藏行标和列标  
        .DisplayGridlines = False                '隐藏行标和列标  
        .DisplayWorkbookTabs = False             '隐藏行标和列标  
    End With  
End Sub  
  
Sub other()  
    With Application  
        .DisplayFormulaBar = False          '隐藏编辑栏  
        .CommandBars.DisableAskAQuestionDropdown = True  '隐藏帮助  
        .CommandBars("ply").Enabled = False        '右键单击工作表标签后不显示菜单  
        .CommandBars("cell").Enabled = False       '右键单击工作表区域后不显示菜单  
        .DisplayStatusBar = False        '隐藏状态栏  
        .ShowStartupDialog = False       '隐藏任务窗格  
    End With  
End Sub  
  
Sub dengji()  
    Dim xrow As Integer  
    With Worksheets("调查结果")  
        xrow = .\[A1\].CurrentRegion.Rows.Count + 1      '取得第一条空行行号  
        .Cells(xrow, "A") = \[d5\]                       '写入学员ID  
        '写入2到9题选择结果  
        .Cells(xrow, "B").Resize(1, 16).Value = Application.WorksheetFunction.Transpose(\[j10:j25\].Value)  
        .Cells(xrow, "R").Value = \[B67\].Value    '写入学员对培训中心的建议  
    End With  
    Union(\[d5:e5\], \[j10:j25\], \[b67:g67\]).ClearContents '清除调查问卷中原有答案  
    MsgBox "已保存到“调查结果”工作表中！", vbInformation, "提示"  
End Sub  
  
Dim nrow As Long   '定义一个模块级的变量，让该模块  
Private Sub cmdfind\_click()    '单击“查询”按钮时运行程序  
'判断按什么方式进行查找  
    Dim col As Integer  
    If findname.Value = True Then  
        col = 7           '如果按身份证号查找，则查找第7列  
    Else  
        col = 1           '如果按职工编号查找，则查找第1列  
    End If  
    With Worksheets("职工档案")  
        Dim rng As Range  
        '在查找列查找输入的关键字  
        Set rng = .Columns(col).Find(findtext.Value, lookat:=xlWhole)  
        If Not rng Is Nothing Then    '判断是否找到内容匹配的单元格  
            nrow = rng.Row            '取得查找到的单元格的行号  
            Call findi                '运行findi子过程  
        Else  
            MsgBox "没有找到符合条件的记录！"  
        End If  
        findtext.Value = ""       '清除查找框中输入的数据  
    End With  
End Sub  
  
Private Sub cmdadd\_click()   '单击“新增”按钮时运行程序  
    '判断在对话框中按下哪个按钮  
    If MsgBox("确定在“职工档案”中添加该员工的记录吗？", vbQuestion + vbYesNo, "询问") = vbYes Then  
    '取得第一条空行行号  
        nrow = Worksheets("职工档案").Range("A1").CurrentRegion.Rows.Count + 1  
        Call edit      '运行edit过程  
    End If  
End Sub  
  
Private Sub cmddel\_click()   '单击“删除”按钮时运行程序  
    '判断在对话框中按下哪个按钮  
    If MsgBox("确定将该员工信息移动到“删除”工作表中吗？", vbQuestion + vbYesNo, "询问") = vbYes Then  
        '取得当前“职工编号”所在的行号  
        nrow = Worksheets("职工档案").Range("A1:A65536").FING(Range("C7").Value, lookat:=xlWhole).Row  
        '把记录复制到“删除”工作表中  
        Worksheets("职工档案").Rows(nrow).Copy Worksheets("删除").Range("A65536").End(xlUp).Offset(1, 0)  
        '删除该条记录  
        Worksheets("职工档案").Cells(nrow, "A").EntireRow.Delete  
    End If  
End Sub  
  
Private Sub cmdedit\_click()  '单击“修改”按钮时运行程序  
    '判断在对话框中按下哪个按钮  
    If MsgBox("确定修改“职工档案”中该员工的信息吗？", vbQuestion + vbYesNo, "询问") = vbYes Then  
        '取得当前“职工编号”所在的行号  
        nrow = Worksheets("职工档案").Range("A1:A65536").FING(Range("C7").Value, lookat:=xlWhole).Row  
        Call edit         '运行edit过程  
    End If  
End Sub  
  
Private Sub cmdfirst\_click()  '单击“第一条”按钮时运行程序  
    nrow = 2     '行号等于2  
    Call fini    '运行findi子过程  
End Sub  
  
Private Sub cmdend\_click()  '单击“最后一条”按钮时运行程序  
'取得最后一条记录的行号  
    nrow = Worksheets("职工档案").Range("A1").CurrentRegion.Rows.Count  
    Call fini    '运行findi子过程  
End Sub  
  
Private Sub cmdformer\_click()  '单击“上一条”按钮时运行程序  
'取得当前“职工编号”所在行的上一行行号  
    nrow = Worksheets("职工档案").Range("A2:A65536").FING(Range("C7").Value, lookat:=xlWhole).Row - 1  
    Call findi  '运行findi过程  
End Sub  
  
Private Sub cmdnext\_click()  '单击“下一条”按钮时运行程序  
'取得当前“职工编号”所在行的下一行行号  
    nrow = Worksheets("职工档案").Range("A2:A65536").FING(Range("C7").Value, lookat:=xlWhole).Row + 1  
    Call findi  '运行findi过程  
End Sub  
  
Sub findi()   '子过程  
'将“职工档案”中第nrow行的记录写入“查询”表中  
    With Worksheets("职工档案")  
        Range("C7:E7").Value = .Range(.Cells(nrow, 1), .Cells(nrow, 3)).Value  
        Range("C10:E10").Value = .Range(.Cells(nrow, 4), .Cells(nrow, 6)).Value  
        Range("C13").Value = .Cells(nrow, 7).Value  
        Range("E13").Value = .Cells(nrow, 8).Value  
        Range("C16:E16").Value = .Range(.Cells(nrow, 9), .Cells(nrow, 11)).Value  
        Range("C19").Value = .Cells(nrow, 12).Value  
    End With  
End Sub  
  
Sub edit()   '子过程  
    '将查询表中的记录添加到第nrow行中  
    With Worksheets("职工档案")  
        .Cells(nrow, "A").Resize(1, 3) = Range("C7:E7").Value  
        .Cells(nrow, "D").Resize(1, 3) = Range("C10:E10").Value  
        .Cells(nrow, 7).Value = Range("C13").Value  
        .Cells(nrow, 8).Value = Range("E13").Value  
        .Cells(nrow, 9).Resize(1, 3).Value = Range("C16:E16").Value  
        .Cells(nrow, 12).Value = Range("C19").Value  
    End With  
End Sub  
  
Private Sub workbook\_open()  
    Application.Visible = False     '隐藏EXCEL程序界面  
    denglu.Show                   '显示登陆窗体界面  
End Sub  
  
Sub namevisible()  '隐藏名称  
    Names("username").Visible = False  
    Names("userword").Visible = False  
End Sub  
  
Private Sub cmdok\_click()     '单击“确定”按钮的时候执行过程  
    Application.ScreenUpdating = False       '关闭屏幕更新  
    Static i As Integer                     '声明一个变量  
    '判断用户名和密码是否输入正确  
    If CStr(user.Value) = Right(Names("username").RefersTo, Len(Names(UserName).RefersTo) - 1) And CStr(Password.Value) = Right(Names("userword").RefersTo, Len(Names  
  
("userword").RefersTo) - 1) Then  
        Unload Me    '关闭登陆窗体  
        Application.Visible = True      '显示EXCEL界面  
    Else  
        i = i + 1  '密码或用户输入错误一次，变量i加1  
        If i = 3 Then     '如果输错3次执行if到else间的语句  
            MsgBox "对不起，你无权打开工作簿！", vbInformation, "提示"  
                ThisWorkbook.Close savechanges:=False  '关闭当前工作簿，不保存更改  
        Else  
            MsgBox "输入错误，你还有" & (3 - i) & "次输入机会。", vbExclamation, "提示"  
                user.Value = ""      '清除文字框中的用户名  
            Password.Value = ""      '清除文字框中的密码  
        End If  
    End If  
    Application.ScreenUpdating = True   '开启屏幕更新  
End Sub  
  
Private Sub cmdcancel\_click()    '当单击“退出”按钮时执行过程  
    Unload Me   '关闭登陆窗体  
    ThisWorkbook.Close savechanges:=False   '关闭当前工作簿，不保存修改  
End Sub  
  
Private Sub userset\_click()   '单击“更改用户名”按钮时运行过程  
    Dim old As String, new1 As String, new2 As String  
    old = InputBox("请输入原用户名：", "提示")  
    new1 = InputBox("请输入新用户名：", "提示")  
    new2 = InputBox("请再次输入新用户名：", "提示")  
    If old <> "" And new1 <> "" Then     '判断输入的用户名是否为空  
        '判断新旧用户名是否输入正确  
        If old = Right(Names("username").RefersTo, Len(Names("username").RefersTo) - 1) And new1 = new2 Then  
            Names("username").RefersTo = "=" & new1 '修改名称值  
            ThisWorkbook.Save      '报存更改  
            MsgBox "用户名修改完成，下次登录请使用新用户名！", vbiformation, "提示"  
        Else  
            MsgBox "输入错误，修改没有完成！", vbCritical, "错误"  
        End If  
    Else  
        MsgBox "用户名不能为空！", vbCritical, "错误"  
    End If  
End Sub  
  
Private Sub passwwordset\_click()     '当单击“更改密码”按钮时运行过程  
    Dim old As String, new1 As String, new2 As String  
    old = InputBox("请输入原密码：", "提示")  
    new1 = InputBox("请输入新密码：", "提示")  
    new2 = InputBox("请再次输入密码：", "提示")  
    If old <> "" And new1 <> "" Then     '判断输入的密码是否为空  
        '判断新旧密码是否输入正确  
        If old = Right(Names("userword").RefersTo, Len(Names("userword").RefersTo) - 1) And new1 = new2 Then  
            Names("userword").RefersTo = "=" & new1 '修改名称值  
            ThisWorkbook.Save      '报存更改  
            MsgBox "用户名修改完成，下次登录请使用新密码！", vbiformation, "提示"  
        Else  
            MsgBox "输入错误，修改没有完成！", vbCritical, "错误"  
        End If  
    Else  
        MsgBox "密码不能为空！", vbCritical, "错误"  
    End If  
End Sub  
  
Private Sub userform\_queryclose(cancel As Integer, closemode As Integer)  
'当单击窗体右上角关闭按钮时运行程序  
    If closemode <> 1 Then cancel = 1  
End Sub  
  
Sub bycy()  
    If Range("A1").Value > 0 Then  
        MsgBox "A1单元格的数是正数。"  
End Sub  
  
Sub yxscw()  
    Kill ThisWorkbook.FullName    '删除代码坐在的工作簿文件  
End Sub  
  
Sub ljcy()  
    Dim i As Integer  
    For i = 1 To 10  
        Cells(1, 1).Value = i   '事实上，数据永远都被写入A1单元格里  
    Next  
End Sub  
  
Sub stoptest()  
    Dim i As Long  
    i = 1  
    Do Until i < 1  
        i = i + 1  
    Loop  
End Sub  
'按ESC或ctrl+break会中断运行  
  
Sub test()  
    Dim i As Integer  
    For i = 1 To 100 Step 2  
        Cells(i, "A").Value = i  
        Debug.Print "i=" & i   '将表达式的值输出到立即窗口中  
End Sub  
  
Sub test()  
    On Error GoTo a                     '如果发生错误，则转到标签a的语句行  
    Worksheets("abc").Select            '如果工作表中没有abc工作表，程序会发生错误  
    Exit Sub  
a:     MsgBox "没有要选择的工作表！"  
End Sub  
  
Sub test()  
    On Error Resume Next                     '忽略该行代码之后出现的运行时错误  
    Worksheets("abc").Select  
    Exit Sub                    '退出程序  
    MsgBox "没有要选择的工作表！"  
End Sub  
  
Sub test()  
    On Error Resume Next                     '忽略该行代码之后出现的运行时错误  
    Worksheets("abc").Select                 '如果工作表中没有abc工作表，程序会发生错误  
    On Error GoTo 0                          '关闭错误捕捉  
    Worksheets("def").Select                 '如果工作簿中没有def工作表，程序会出错  
    Exit Sub                                 '退出程序  
a:        MsgBox "没有要选择的工作表！"  
End Sub  
'因为程序开始时已经设置了忽略程序中的运行时错误，但因为关闭了错误捕捉，所以 On Error GoTo 0 代码后发生的错误将不会被忽略  
  
Sub test()  
    Dim rng As Range  
    Set rng = Worksheets(1).Range("A1:D100")  
    rng = 200  
    Set rng = Nothing    '将rng变量与worksheets(1).range("A1:D100")分离开  
End Sub  
'nothing被赋值给一个对象变量后，该变量不再引用任何对象。  
  
  
Sub test()  
    ThisWorkbook.Worksheets(1).Range("A1").Clear  
    ThisWorkbook.Worksheets(1).Range("A1").Value = "excel home"  
    ThisWorkbook.Worksheets(1).Range("A1").Font.Name = "宋体"  
    ThisWorkbook.Worksheets(1).Range("A1").Font.Size = 16  
    ThisWorkbook.Worksheets(1).Range("A1").Font.Bold = True  
    ThisWorkbook.Worksheets(1).Range("A1").Font.ColorIndex = 3  
End Sub  
  
Sub withtest()  
    With ThisWorkbook.Worksheets(1).Range("A1")  
        .Clear  
        .Value = "excel home"  
        .Font.Name = "宋体"  
        .Font.Size = 16  
        .Font.Bold = True  
        .Font.ColorIndex = 3  
    End With  
End Sub  
  
Sub withtest2()  
    With ThisWorkbook.Worksheets(1).Range("A1")  
        .Clear  
        .Value = "excel home"  
        With .Font  
            .Name = "宋体"  
            .Size = 16  
            .Bold = True  
            .ColorIndex = 3  
        End With  
    End With  
End Sub  
  
Sub objecttest()  
    Dim rng As Range  
    Set rng = ThisWorkbook.Worksheets(1).Range("A1")  
    rng.Clear  
    rng.Value = "excel home"  
    rng.Font.Name = "宋体"  
    rng.Font.Size = 16  
    rng.Font.Bold = True  
    rng.Font.ColorIndex = 3  
End Sub  
  
Sub objecttest\_2()  
    Dim rng As Range  
    Set rng = ThisWorkbook.Worksheets(1).Range("A1")  
    With rng  
        .Clear  
        .Value = "excel home"  
        .Font.Name = "宋体"  
        .Font.Size = 16  
        .Font.Bold = True  
        .Font.ColorIndex = 3  
    End With  
End Sub  
  
  
Sub macrol()  
    Range("A1").Select  
    Selection.Copy  
    Sheets("sheet2").Select  
    Range("B1").Select  
    ActiveSheet.Paste  
    Sheets("sheet1").Select  
End Sub  
  
  
Sub macro2()  
    Range("A1").Copy Sheets("sheet2").Range("B1")  
End Sub  
  
Sub inputtxt()  
    Dim start As Double  
    start = Timer           '取得从午夜开始到程序运行时经过的秒数  
    Dim i As Long  
    For i = 1 To 65536  
        Cells(i, "A").Value = i  
    Next  
    MsgBox "程序运行的时间约是" & Format(Timer - start, "0.00") & "秒"  
End Sub  
  
Sub inputarr()      '运行效率更高  
    Dim start As Double  
    start = Timer           '取得从午夜开始到程序运行时经过的秒数  
    Dim i As Long, arr(1 To 65536) As Long  
    For i = 1 To 65536  
        arr(i) = i  
    Next  
    Range("A1:A65536").Value = Application.WorksheetFunction.Transpose(arr)  
    MsgBox "程序运行的时间约是" & Format(Timer - start, "0.00") & "秒"  
End Sub  
  
Sub inputarr\_2()  
    Dim start As Double  
    start = Timer           '取得从午夜开始到程序运行时经过的秒数  
    Dim i As Long, arr(1 To 65536, 1 To 1) As Long  
    For i = 1 To 65536  
        arr(i, 1) = i  
    Next  
    Range("A1:A65536").Value = arr  
    MsgBox "程序运行的时间约是" & Format(Timer - start, "0.00") & "秒"  
End Sub