1 有内容的最行一行、列

lr = Range("A" & Cells.Rows.Count).End(xlUp).Row + 1lc = 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 functionApplication.ReferenceStyle = xlA1Application.ReferenceStyle = xlR1C1

6 清除密码保护

Sub clearPassWord()    Dim wkb As Workbook    For Each wkb In Workbooks        If wkb.HasPassword Then            wkb.Password = ""        End If    Next wkbEnd 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 SubSub proc()    Debug.Print 1314End Sub

9 Read a file

Const ForReading = 1Const ForWriting = 2Const ForAppending = 8Sub 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	o\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.CloseEnd 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	o\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 fileEnd 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 WithEnd Sub

12 清除条件格式

Sub 清除条件格式()    Cells.FormatConditions.DeleteEnd 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 iEnd 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 = 1End Sub

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

Sub 设置工作表标签颜色()    For Each sh In Worksheets        r = Rnd() * 255        g = Rnd() * 255        b = Rnd() * 255        sh.Tab.Color = RGB(r, g, b)    NextEnd SubSub 恢复工作表标签颜色()    For Each sht In Worksheets        sht.Tab.ColorIndex = xlColorIndexNone    NextEnd 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 IfEnd 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 Witherr1:        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 SubFunction 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 = rEnd 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 = xlNoRestrictionsEnd SubSub 取消保护()    ActiveSheet.Unprotect    Worksheets("Sheet1").Range("A1").CurrentRegion.Select    Selection.Locked = False    Selection.FormulaHidden = FalseEnd 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:=FalseEnd Sub

ref:

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

－End－