1 有内容的最行一行、列

lr = Range("A" & Cells.Rows.Count).End(xlUp).Row 1 lc = Range(Cells(1, Columns.Count), Cells(1, Columns.Count)).End(xlToLeft).Column 1

2 数组填充

[E1:F1] = Array("产品名称", "数量") '填充表头 ActiveSheet.Range("A3:B3") = Array("外部库名称", "描述", "文件位置") '填充表头

3 字符串处理函数

s1 = Len(s) 求长度 s1 = Trim(s) 去两边空格 s1 = Replace(s,a,b) 替换字符串 s1 = LCase(s) 小写字符串 s1 = UCase(s) 大写字符串 s1 = Left(s,n) 从左边取出n个字符 s1 = Right(s,n) 从右边取出n个字符 s1 = Mid(s,i,n) 从s的第i个字符开始取出n个字符 s1 = Instr(s,a) 查找字符串a的位置 s1 = Instr(i,s,a) 从第i个字符开始寻找a，返回a首字母的位置

4 单元格操作

合并单元格 Range.Merge 拆分单元格 Range.UnMerge 清除内容 Range.ClearContents 清除格式 Range.ClearFormats 内容格式全部清除 Range.Clear 修改字号 Range.Font.Size 修改颜色Range.Font.Color = RGB(255,0,0) 修改字颜色Range.Interior.Color = RGB（255，255，0）

5 引用方式A1和R1C1转换

'A1转R1C1： Function TransferFromat(byval rangeAdd as string) as string dim str as string str =Application.ConvertFormula(rangeAdd , xlA1, xlR1C1) TransferFromat=str end function 'R1C1转A1： function TransferFromat(byval rangeAdd as string) as string dim str as string str =Application.ConvertFormula(rangeAdd ,xlR1C1, xlA1 ) TransferFromat=str end function Application.ReferenceStyle = xlA1 Application.ReferenceStyle = xlR1C1

6 清除密码保护

Sub clearPassWord() Dim wkb As Workbook For Each wkb In Workbooks If wkb.HasPassword Then wkb.Password = "" End If Next wkb End Sub

7 空表判断

If Application.WorksheetFunction.CountA(Cells) <> 0 Then MsgBox "活动工作表中包含数据，请选择一个空工作表！" Exit Sub End If

8 定时运行程序

Sub ontime() dNextTime = DateAdd("s", 5, Now) '5 second Application.ontime dNextTime, "proc" End Sub Sub proc() Debug.Print 1314 End Sub

9 Read a File

Const ForReading = 1 Const ForWriting = 2 Const ForAppending = 8 Sub ReadTextFileExample() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim sourceFile As Object Dim myFilePath As String Dim myFileText As String myFilePath = "C:\mypath\to\myfile.txt" GoalKicker.com – vbA Notes for Professionals 96 Set sourceFile = fso.OpenTextFile(myFilePath, ForReading) myFileText = sourceFile.ReadAll ' myFileText now contains the content of the text file sourceFile.Close ' close the file ' do whatever you might need to do with the text ' You can also read it line by line Dim line As String Set sourceFile = fso.OpenTextFile(myFilePath, ForReading) While Not sourceFile.AtEndOfStream ' while we are not finished reading through the file line = sourceFile.ReadLine ' do something with the line... Wend sourceFile.Close End Sub

10 Creating and write a text file

Sub CreateTextFileExample() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim targetFile As Object Dim myFilePath As String Dim myFileText As String myFilePath = "C:\mypath\to\myfile.txt" Set targetFile = fso.CreateTextFile(myFilePath, True) ' this will overwrite any existing file targetFile.Write "This is some new text" targetFile.Write " And this text will appear right after the first bit of text." targetFile.WriteLine "This bit of text includes a newline character to ensure each write takes its own line." targetFile.Close ' close the file End Sub

11 设置条件格式

Sub 设置条件格式() Dim rng1 As Range Set rng1 = Sheet1.Range("C2:E6") '添加条件格式，成绩大于或等于90 的格式 With rng1.FormatConditions.Add(Type:=xlCellValue, _ Operator:=xlGreaterEqual, Formula1:=90) With .Borders .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = 6 End With With .Font .Bold = True 第4 章 Range 对象操作技巧 105 .ColorIndex = 3 End With End With '添加条件格式，成绩小于60 的格式 With rng1.FormatConditions.Add(Type:=xlCellValue, _ Operator:=xlLess, Formula1:=60) With .Font .Bold = True .ColorIndex = 10 End With End With End Sub

12 清除条件格式

Sub 清除条件格式() Cells.FormatConditions.Delete End Sub

13 排序工作表

Sub 排序工作表() Dim i As Long, j As Long For i = 1 To Worksheets.Count For j = 1 To Worksheets.Count - 1 If UCase$(Worksheets(j).Name) > UCase$(Worksheets(j 1).Name) Then Worksheets(j).Move After:=Worksheets(j 1) End If Next j Next i End Sub

14 重命名工作表

Sub 重命名工作表() Dim str1 As String Do Err.Clear str1 = Application.InputBox( _ prompt:="请输入工作表的新名称（输入空白，则退出程序）：", _ Title:="重命名工作表", Type:=2) If str1 = "" Or str1 = "False" Then Exit Do On Error Resume Next ActiveSheet.Name = str1 If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description Err.Clear End If Loop While 1 = 1 End Sub

15 工作表标签颜色设置与恢复

Sub 设置工作表标签颜色() For Each sh In Worksheets r = Rnd() * 255 g = Rnd() * 255 b = Rnd() * 255 sh.Tab.Color = RGB(r, g, b) Next End Sub Sub 恢复工作表标签颜色() For Each sht In Worksheets sht.Tab.ColorIndex = xlColorIndexNone Next End Sub

16 判断工作簿是否打开

Private Function WorkbookIsOpen(WorkBookName As String) As Boolean '如果该工作簿已打开，则返回真 Dim wb As Workbook On Error Resume Next Set wb = Workbooks(WorkBookName) If Err = 0 Then WorkbookIsOpen = True Else WorkbookIsOpen = False End If End Function

17 工作簿备份：

Sub 备份工作簿() Dim wb As Workbook, FileName As String, i As Integer, OK As Boolean Set wb = ActiveWorkbook '获取对当前工作簿的引用 If wb.Path = "" Then '如果还未保存 Application.Dialogs(xlDialogSaveAs).Show '显示另存为对话框 End If FileName = wb.FullName '获取工作簿的全路径名称 i = InStrRev(FileName, ".") If i > 0 Then FileName = Left(FileName, i - 1) '生成扩展名".bak" FileName = FileName & ".bak" OK = False On Error GoTo err1 With wb Application.StatusBar = "正在保存工作簿..." .Save '保存工作簿 Application.StatusBar = "正在备份工作簿..." .SaveCopyAs FileName '备份工作簿 OK = True End With err1: Set wb = Nothing Application.StatusBar = False '恢复状态栏 If Not OK Then '如果未备份成功 MsgBox "备份工作簿操作失败!", vbExclamation, ThisWorkbook.Name End If End Sub

18 工作簿之间数据引用：

Sub 获取其他工作簿数据() Dim wb As Workbook '以只读方式打开工作簿 Set wb = Workbooks.Open("F:\工作簿间数据引用\a\a.xlsx", True, True) With ThisWorkbook.Worksheets("Sheet1") '从工作簿中读取数据 ' 方式1，从打开的工作簿引用 .Range("B2") = wb.Worksheets("Sheet1").Range("B2") _ wb.Worksheets("Sheet1").Range("B3") _ wb.Worksheets("Sheet1").Range("B4") ' 方式2，使用公式和绝对路径 .Range("B3").Formula = "=SUM('F:\工作簿间数据引用\b\[b.xlsx]Sheet1'!$C$2:$C$4)" ' 方式3，将方式2的使用定义为一个函数 .Range("B4").Formula = GetClosedData("F:\工作簿间数据引用\b", "b.xlsx", "Sheet1", "D2:D4") End With wb.Close False '关闭打开的工作簿且不保存任何变化 Set wb = Nothing '释放内存 End Sub Function GetClosedData(ByVal path As String, ByVal WorkbookName As String, _ ByVal SheetName As String, ByVal RangeName As String) '参数Path 为工作簿路径 '参数WorkbookName 为工作簿名称 '参数SheetName 为工作表名称 '参数RangeName 为单元格区域 Dim r r = "=sum('" & path & "\[" & WorkbookName & "]" r = r & SheetName & "'!" & RangeName & ")" GetClosedData = r End Function

19 锁定和隐藏公式

Sub 锁定和隐藏公式() If ActiveSheet.ProtectContents = True Then MsgBox "工作表已保护！" Exit Sub End If Worksheets("Sheet1").Range("A1").CurrentRegion.Select Selection.Locked = False Selection.FormulaHidden = False Selection.SpecialCells(xlCellTypeFormulas).Select Selection.Locked = True Selection.FormulaHidden = True Worksheets("Sheet1").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True Worksheets("Sheet1").EnableSelection = xlNoRestrictions End Sub Sub 取消保护() ActiveSheet.Unprotect Worksheets("Sheet1").Range("A1").CurrentRegion.Select Selection.Locked = False Selection.FormulaHidden = False End Sub

20 整点报时

'打开整点报时 Sub starttime() Application.OnTime EarliestTime:=TimeSerial((Hour(Now) 1) Mod 24, 0, 0), _ Procedure:="starttime" MsgBox "现在时间是：" & Hour(Now) & " 点！" End Sub '结束整点报时 Sub endtime() On Error Resume Next Application.OnTime EarliestTime:=TimeSerial((Hour(Now) 1) Mod 24, 0, 0), _ Procedure:="starttime", schedule:=False End Sub

ref:

吴永佩，成丽君 《征服Excel VBA：让你工作效率倍增的239 个实用技巧 》

－End－