VBA代码摘录.docx

VBA精粹摘录lLastRow = Sheets(Database).UsedRange.Rows.Count获取Database工作表中已使用区域的行数并赋值给变量lLastRowRange(B5:G65536).Clear清除B5:G65536范围数据Sheets(Database).Range(A1:F & lLastRow)使用变量lLastRow扩展数据列表lLastRow = Range(A & Cells.Rows.Count).End(xlUp).Row获取A列最后一行行数Range(E3:E & lLastRow).FormulaR1C1 = =RC2*RC3*RC4在E列计算范围内，按R1C1规则计算引用工作表的方法：Worksheets(“sheet1”).ActivateSheets(“sheet1”).ActivateWorkSheets集合包含所有工作表。而Sheets集体不仅包含工作表集合WorkSheets,还包含图表集合Chats、宏表集合等。任何时刻工作簿中只有一个工作表是活动工作表。-设置加班费列的格式并突出显示最大值Sub SetFormat(rngF As Range) With rngF .NumberFormat = 0.00 .HorizontalAlignment = xlCenter .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:=RC5=max(C5) .FormatConditions(1).Interior.ColorIndex = 4 End WithEnd Sub把二个比较数据置换位置方法：For i = 1 To n - 1 比较排序 For j = i + 1 To n If nSht(i) = 500End SubSub bjb() MsgBox Range(B2) Like 李*End SubSub lja() MsgBox Range(C2) = 60 Or Range(D2) = 60End Sub-If.Then语句Option ExplicitSub SayZsh() If Time 0.5 Then MsgBox 早上好!End SubSub SayHello() If Time = 0.5 Then MsgBox 下午好!End SubSub SayHello2() If Time 0.5 Then MsgBox 早上好! Else MsgBox 下午好!End SubSub SayHello3() If Time 0.5 Then MsgBox 早上好! Else MsgBox 下午好! End IfEnd SubSub SayHello4() If Time 0.75 Then MsgBox 晚上好! Else MsgBox 下午好! End IfEnd Sub-Select Case根据考核分评定职工星级Option ExplicitSub xingji() Dim xj As String Select Case Cells(2, 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(2, I) = xjEnd Sub-Select Case语句Option ExplicitSub SayHello() Select Case Time Case Is 0.75 MsgBox 晚上好! Case Else MsgBox 下午好! End SelectEnd Sub-For.Next语句Option ExplicitSub 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 iEnd Sub-Do.While语句Option ExplicitSub xingji_1() Dim xj As String, i As Integer i = 2 Do While Cells(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 LoopEnd Sub-For Each.Next语句 将工作表名称写入A列Option ExplicitSub shtname() Dim sht As Worksheet, i As Integer i = 1 第1次待写入单元格在第1行，所以变量值定义为1 For Each sht In Worksheets Cells(i, A) = sht.Name 将工作表名称写入A列第i行的单元格 i = i + 1 Next shtEnd Sub-GoTo语句Option ExplicitSub he() Dim mysum As Long, i As Integer i = 1 第1个数字为1x: mysum = mysum + i i = i + 1 变量i的值增加 If i = 100 Then GoTo x 如果i小于或等于100，转到x标签处 MsgBox 1到100的自然数和是： & mysumEnd Sub-With语句Option ExplicitSub 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 SubSub FontSet_2() With Worksheets(Sheet1).Range(A1).Font .Name = 仿宋 .Size = 12 .Bold = True .ColorIndex = 3 End WithEnd Sub-从另一个过程执行过程（共三种方法）Option ExplicitSub SayHello() If Time 0.75 Then MsgBox 晚上好! Else MsgBox 下午好! End IfEnd SubSub RunSub_1() SayHelloEnd SubSub RunSub_2() Call SayHelloEnd SubSub RunSub_3() Application.Run SayHelloEnd Sub-过程的作用域Option ExplicitOption Private ModulePublic Sub gggc() MsgBox 我是公共过程！End SubPrivate Sub sygc() MsgBox 我是私有过程！End Sub-试写一个函数Option ExplicitPublic Function Fun() Fun = Int(Rnd() * 10) + 1End FunctionSub msg() MsgBox Fun()End Sub-怎么统计指定颜色的单元格个数Option ExplicitFunction Countcolor(arr As Range, c As Range) Dim rng As Range For Each rng In arr If rng.Interior.Color = c.Interior.Color Then Countcolor = Countcolor + 1 End If Next rngEnd Function-ScreenUpdating属性Option ExplicitSub InputTest_1() Cells.ClearContents 清除表中所有数据 Range(A1:A10) = 100 在A1:A10单元格输入数值 MsgBox 刚才在A1：A10输入数值100，你能看到结果吗？ 显示提示框 Range(B1:B10) = 200 MsgBox 刚才在B1：B10输入数值200，你能看到结果吗？End SubSub InputTest_2() Cells.ClearContents 清除表中所有数据 Application.ScreenUpdating = False 关闭屏幕更新 Range(A1:A10) = 100 在A1:A10单元格输入数值 MsgBox 刚才在A1：A10输入数值100，你能看到结果吗？ 显示提示框 Range(B1:B10) = 200 MsgBox 刚才在B1：B10输入数值200，你能看到结果吗？ Application.ScreenUpdating = True 恢复屏幕更新End Sub-DisplayAlerts属性（不显示计算结果到屏幕上）Option ExplicitSub DelSht_1() Dim sht As Worksheet 定义变量 For Each sht In Worksheets 遍历所有工作表 If sht.Name ActiveSheet.Name Then 判断sht代表的工作表是不是活动工作表 sht.Delete 删除sht代表的工作表 End If NextEnd SubSub DelSht_2() Dim sht As Worksheet 定义变量 Application.DisplayAlerts = False 不显示警告框 For Each sht In Worksheets 遍历所有工作表 If sht.Name ActiveSheet.Name Then 判断sht代表的工作表是不是活动工作表 sht.Delete 删除sht代表的工作表 End If Next Application.DisplayAlerts = True 恢复显示警告框End Sub-EanbleEvents属性（自动写入单元格地址）Option ExplicitPrivate Sub Worksheet_SelectionChange(ByVal Target As Range) Target.Value = Target.AddressEnd Sub-WorkSheetFunction属性Option ExplicitSub CountTest_1() 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 SubSub CountTest_2() Dim mycount As Integer 定义变量 mycount = Application.WorksheetFunction.CountIf(Range(A1:B50), 1000) MsgBox A1:B50中大于1000的单元格个数为： & mycount 提示框显示结果End Sub-认识Workbook，需要了解的信息Option ExplicitSub wb() Workbooks.Add 新建一个工作薄 MsgBox 代码所在的工作簿为： & ThisWorkbook.Name 显示代码所在工作薄名称 MsgBox 当前活动工作簿为： & ActiveWorkbook.Name 显示当前活动工作薄名称 ActiveWorkbook.Close savechanges:=False 关闭新建工作薄，不保存修改End Sub-保存工作薄Option ExplicitSub SaveWb() ThisWorkbook.Save 保存代码所在的工作薄End SubSub SaveToFile_1() ThisWorkbook.SaveAs Filename:=D:test.Xls 另存为工作薄到D盘，文件名为：test.xlsEnd SubSub SaveToFile_2() ThisWorkbook.SaveCopyAs Filename:=D:test.Xls 另存为工作薄到D盘，文件名为：test.xlsEnd Sub-打开工作薄Option ExplicitSub OpenFile() Workbooks.Open Filename:=d:Book1.xls 打开F盘的Book1.xlsEnd Sub-关闭工作薄Option ExplicitSub CloseWb_1() Workbooks.Close 关闭所有工作薄End SubSub CloseWb_2() Workbooks(Book1.xls).CloseEnd SubSub CloseWb_3() Workbooks(Book1).Close savechanges:=True 关闭并保存修改End Sub-激活工作薄Option ExplicitSub JhWb() Workbooks(Book1).Activate 激活打开的名称为Book1的工作簿End Sub- ThisWorkbook与ActiveWorkbookOption ExplicitSub wb() Workbooks.Add 新建一个工作薄 MsgBox 代码所在的工作簿为： & ThisWorkbook.Name 显示代码所在工作薄名称 MsgBox 当前活动工作簿为： & ActiveWorkbook.Name 显示当前活动工作薄名称 ActiveWorkbook.Close savechanges:=False 关闭新建工作薄，不保存修改End Sub-代码名称Sub ShowShtCode() MsgBox ActiveSheet.CodeNameEnd Sub-复制工作表Option ExplicitSub shtcopy1() MsgBox 下面将把“工资表”复制到“出勤工作表”前