VBA｜几段实用代码

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\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.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\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 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－