Excel常见宏命令.doc

1、清除剪贴板Sub 清除剪贴板 ()Application.CutCopyMode = FalseApplication.CommandBars(“Task Pane“).Visible = FalseEnd Sub批量清除软回车Sub 批量清除软回车()也可直接使用 Alt+10 或 13 替换Cells.Replace What:=Chr(10), Replacement:=“, LookAt:=xlPart, SearchOrder:= _xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=FalseEnd Sub

2、判断指定文件是否已经打开Sub 判断指定文件是否已经打开()Dim x As IntegerFor x = 1 To Workbooks.CountIf Workbooks(x).Name = “函数.xls“ Then 文件名称MsgBox “文件已打开“Exit SubEnd IfNextMsgBox “文件未打开“End Sub当前文件另存到指定目录Sub 当前激活文件另存到指定目录()ActiveWorkbook.SaveAs Filename:=“E:信件“ & ActiveWorkbook.NameEnd Sub另存指定文件名Sub 另存指定文件名()ActiveWorkbook.

3、SaveAs ThisWorkbook.Path & “别名.xls“End Sub以本工作表名称另存文件到当前目录Sub 以本工作表名称另存文件到当前目录()ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & “ & ActiveSheet.Name & “.xls“End Sub将本工作表单独另存文件到 Excel 当前默认目录Sub 将本工作表单独另存文件到 Excel 当前默认目录()ActiveSheet.CopyActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & “.xls“End

4、 Sub以活动工作表名称另存文件到 Excel 当前默认目录Sub 以活动工作表名称另存文件到 Excel 当前默认目录()ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & “.xls“, FileFormat:= _xlNormal, Password:=“, WriteResPassword:=“, ReadOnlyRecommended:=False _, CreateBackup:=FalseEnd Sub另存所有工作表为工作簿Sub 另存所有工作表为工作簿()Dim sht As WorksheetApplication.Scree

5、nUpdating = Falseipath = ThisWorkbook.Path & “For Each sht In Sheetssht.CopyActiveWorkbook.SaveAs ipath & sht.Name & “.xls“ (工作表名称为文件名）ActiveWorkbook.SaveAs ipath & sht.Name & Trim(sht.d15) & “.xls“ （文件名称 & D15 单元内容）ActiveWorkbook.SaveAs ipath & Trim(sht.d15) & “.xls“ （文件名称为 D15 单元内容）ActiveWorkbook.

6、CloseNextApplication.ScreenUpdating = TrueEnd Sub以指定单元内容为新文件名另存文件Sub 以指定单元内容为新文件名另存文件()ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & “ & Sheet1.A1End Sub以当前日期为新文件名另存文件Sub 以当前日期为新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path & “ & Format(Now(), “yyyymmdd“) & “.xls“End SubSub 以当前日期为名称另存文件()Active

7、Workbook.SaveAs Filename:=Date & “.xls“End Sub以当前日期和时间为新文件名另存文件Sub 以当前日期和时间为新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path & “ & Format(Now(), “yyyy“ & “年“ & “mm“ & “月“ & “dd“ & “日“ & “h“ & “时“ & “mm“ & “分“ & “ss“ & “秒“) & “.xls“End Sub另存本表为 TXT 文件Sub 另存本表为 TXT 文件()Dim s As StringDim FullName As St

8、ring, rng As RangeApplication.ScreenUpdating = FalseFullName = (ActiveSheet.Name & “.txt“) 以当前表名为TXT 文件名 FullName = Replace(ThisWorkbook.FullName, “.xls“, “.txt“) 以当前文件名为 TXT 文件名 FullName = Replace(ThisWorkbook.FullName, “.xls“, ActiveSheet.Name & “.txt“) 以文件名&表名为 TXT 文件名Open FullName For Output As

9、#1 以读写方式打开文件，每次写内容都会覆盖原先的内容参考帮助， fullname 为文件全名For Each rng In Range(“a1“).CurrentRegions = s & IIf(s = “, “, “|“) & rng.ValueIf rng.Column = Range(“a1“).CurrentRegion.Columns.Count ThenPrint #1, s & “|“ 把数据写到文本文件里s = “End IfNextClose #1 关闭文件Application.ScreenUpdating = TrueMsgBox “数据已导入文本“End Sub引用

10、指定位置单元内容为部分文件名另存文件Sub 引用指定位置单元内容为部分文件名另存文件()ActiveWorkbook.SaveAs Filename:=“E:信件“ & “解答“ & Range(“sheet1!a1“) & “郎雀.xls“End Sub将 A 列数据排序到 D 列Sub 将 A 列数据排序到 D 列()d:d = a:a.Valued:d.Sort Key1:=Range(“D1“), Order1:=xlAscending, Header:=xlYesEnd Sub将指定范围的数据排列到 D 列Sub 将指定范围的数据排列到 D 列()Dim arr1, arr2, i%

11、, xarr1 = Range(“A1:C3“)ReDim arr2(1 To UBound(arr1, 1) * UBound(arr1, 2), 1 To 1)For Each x In Application.Transpose(arr1)i = i + 1arr2(i, 1) = xNext xRange(“D1“).Resize(i, 1) = arr2End Sub光标移动Sub 光标移动 ()ActiveCell.Offset(1, 2).Select 向下移动 1 行，向右移动 2 列End Sub光标所在行上移一行Sub 光标所在行上移一行()Dim i%i = Split(

12、ActiveCell.Address, “$“)(2)If i 1 ThenRows(i).CutRows(i - 1).Insert Shift:=xlDownEnd IfEnd Sub加数据有效限制Sub 加数据有效限制()With Selection.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _xlBetween, Formula1:=““.IgnoreBlank = False.InCellDropdown = False.InputTitle = “.Err

13、orTitle = “.InputMessage = “.ErrorMessage = “要奋斗就会有牺牲，死人的事是经常发生的。“.IMEMode = xlIMEModeNoControl.ShowInput = True.ShowError = TrueEnd WithEnd Sub取消数据有效限制Sub 取消数据有效限制()With Selection.Validation.Delete.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _:=xlBetween.IgnoreBlank = Fals

14、e.InCellDropdown = False.InputTitle = “.ErrorTitle = “.InputMessage = “.ErrorMessage = “.IMEMode = xlIMEModeNoControl.ShowInput = True.ShowError = TrueEnd WithEnd Sub重排窗口Sub 重排窗口 ()Application.CommandBars(“Web“).Visible = FalseApplication.CommandBars(“我的工具“).Visible = FalseWindows.Arrange ArrangeSty

15、le:=xlCascadeEnd Sub按当前单元文本选择打开指定文件单元Sub 选择打开文件单元()Dim aa = ActiveCell.ValueRange(a).Worksheet.ActivateRange(a).SelectEnd Sub回车光标向右Sub 录入光标向右 ()Application.MoveAfterReturnDirection = xlToRightEnd Sub回车光标向下Sub 录入光标向下 ()Application.MoveAfterReturnDirection = xlDownEnd Sub保护工作表时取消选定锁定单元Sub 取消选定锁定单元()Ac

16、tiveSheet.EnableSelection = xlUnlockedCells 用于2000 版End Sub保存并退出 ExcelSub 保存并退出 Excel()Application.SendKeys (“ENTERENTER%fx“)ActiveWorkbook.SaveEnd Sub隐藏/显示指定列空值行Sub 隐藏显示 E 列空值行()Range(“E1:E1000“).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = Not (Range(“E1:E1000“).SpecialCells(xlCellTypeBlanks)

17、.EntireRow.Hidden)End Sub深度隐藏指定工作表Sub 深度隐藏指定工作表()Sheets(“用户名密码“).Visible = xlVeryHiddenEnd Sub隐藏指定工作表Sub 隐藏指定工作表()Sheets(“用户名密码“).Visible = falseEnd Sub隐藏当前工作表Sub 隐藏当前工作表()ActiveWindow.SelectedSheets.Visible = falseEnd Sub返回当前工作表名称Sub 返回当前工作表名称()wsName = ActiveSheet.NameMsgBox “当前工作表为：“ & wsNameEnd

18、Sub获取上一次所进入工作簿的工作表名称Sub 获取上一次所进入工作簿的工作表名称()MsgBox Workbooks(2).ActiveSheet.NameEnd Sub按光标选定颜色隐藏本列其他颜色行Sub 按颜色筛选 () 思路就是: 其它背景色之行全部隐藏Dim UseRow, AC, i 首先选择一个有颜色之单元格，然后动行宏，其它颜色所在行隐藏UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格If ActiveCell.Row UseRow

19、 ThenMsgBox “请在要筛选的区域选择一个有颜色之单元格！“, vbExclamation, “错误“ElseAC = ActiveCell.ColumnCells.EntireRow.Hidden = False 显示所有行For i = 2 To UseRowIf Cells(i, AC).Interior.ColorIndex “录入“ ThenSheets(i).Visible = FalseEnd IfNextEnd Sub除最左边工作表外深度隐藏所有表Sub 除最左边工作表外深度隐藏所有表()For i = 2 To ThisWorkbook.Sheets.CountShe

20、ets(i).Visible = xlSheetVeryHiddenNextEnd Sub关闭文件时自动隐藏指定工作表(ThisWorkbook)Private Sub Workbook_BeforeClose(Cancel As Boolean)ActiveWorkbook.UnprotectSheets(“Sheet2“).Visible = FalseSheets(“Sheet3“).Visible = FalseActiveWorkbook.Protect Structure:=True, Windows:=FalseEnd Sub打开文件时提示指定工作表是保护状态(ThisWorkb

21、ook)Private Sub Workbook_Open()If Worksheets(“Sheet1“).ProtectContents = True ThenMsgBox “ Sheet1 保护了.“End IfEnd Sub插入 10 行Sub 插入 10 行()Rows(ActiveCell.Row & “:“ & ActiveCell.Row + 9).SelectSelection.Insert Shift:=xlDownEnd Sub全选固定范围内小于 0 的单元Sub 全选固定范围内小于 0 的单元()Dim rng As RangeDim yvhfFor Each rng

22、In Range(“d6: i18“)If rng 0 Thenrng.Interior.ColorIndex = 3 文本、假空和大于 0 的单元变红底色End IfNextFor Each rng In Range(“d6: i18“)If rng = 0 Thenrng.Interior.ColorIndex = 2 空值和等于 0 的单元变白底色End IfNextEnd SubA 列半角内容变红Sub A 列半角内容变红()Dim rg As Range, i As LongApplication.ScreenUpdating = FalseFor Each rg In Cells.

23、SpecialCells(xlCellTypeConstants, 3)For i = 1 To Len(rg)If Asc(Mid(rg, i, 1) 0 Then rg.Characters(i).Font.ColorIndex = 3NextNextApplication.ScreenUpdating = TrueEnd Sub单元格录入数据时运行宏的代码Private Sub Worksheet_Change(ByVal Target As Range)重排窗口End Sub焦点到 A 列时运行宏的代码Private Sub Worksheet_SelectionChange(ByVa

24、l Target As Range)If Target.Column = 1 Then宏名End IfEnd Sub根据 B 列最后数据快速合并 A 列单元格的控件代码Private Sub CommandButton1_Click()For i = 1 To b65536.End(xlUp).RowFor j = i + 1 To b65536.End(xlUp).RowIf Range(“a“ & j) = “ ThenRange(“a“ & i & “:a“ & j).MergeElseExit ForEnd IfNext jNext iEnd Sub在 F1 单元显示光标位置批注内容的

25、代码Private Sub Worksheet_SelectionChange(ByVal Target As Range)a = Selection.Addressb = Range(a).NoteTextCells(1, 6) = bEnd Sub显示光标所在单元的批注的代码Dim r As RangePrivate Sub Worksheet_SelectionChange(ByVal Target As Range)On Error Resume Nextr.Comment.Visible = FalseSet r = Targetr.Comment.Visible = TrueEnd

26、 Sub使单元内容保持不变的工作表代码Private Sub Worksheet_Change(ByVal Target As Range)B2 = “不可更改的数据“End Sub有条件执行宏Sub 高级筛选 ()If J1 = 2 Or K1 = “筛选“ ThenColumns(“D:E“).SelectSelection.ClearRange(“D1“).SelectColumns(“A:B“).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _“G1:G2“), CopyToRange:=Range(“D1“),

27、Unique:=FalseEnd IfEnd Sub有条件执行不同的宏Sub 有条件执行不同的宏()If b1.Value = “A“ ThenApplication.Run “宏 1“ElseIf b1.Value = “B“ ThenApplication.Run “宏 2“End IfEnd Sub提示确定或取消执行宏Sub 提示确定或取消执行宏()If vbOK = MsgBox(“确定要复制吗?“, vbOKCancel) ThenRange(“A4:A14“).Copy Range(“b4:b14“)Msgbox “复制结束“End IfEnd Sub提示开始和结束Sub 提示结束

28、 ()Msgbox “运行开始“过程Msgbox “运行结束“End Sub拷贝指定表不相邻多列数据到新位置Sub 拷贝指定表不相邻多列数据到新位置()Sheets(“sheet1“).Range(“A:A,J:J“).Copy Range(“d1“)End Sub选择 2 至 4 行Sub 选择 2 至 4 行()Dim a As IntegerDim b As Integera = 2b = 4Rows(a & “:“ & b).SelectEnd Sub在当前选区有条件替换数值为文本Sub 在当前选区有条件替换数值为文本()For Each r In SelectionIf r.Valu

29、e 18 And r.Value “ Thenwww = www & “,“ & eeEnd IfNextNextwww = Right(www, Len(www) - 1)zxc = Split(www, “,“)For sd = 0 To UBound(zxc) - 1For wee = zxc(sd) + 1 To zxc(sd + 1) - 1Worksheets(“数据库“).Cells(sdf + ier + 1, uu + 4) = Cells(wee, 1)uu = uu + 1Nextsdf = sdf + 1uu = 0NextFor Each hhh In Workshe

30、ets(“临时“).Range(“A6:A6000“).HyperlinksWorksheets(“数据库“).Cells(ier + 1, 2) = hhh.TextToDisplayWorksheets(“数据库“).Cells(ier + 1, 3) = hhh.AddressRange(Worksheets(“数据库“).Cells(ier + 1, 3), Worksheets(“数据库“).Cells(ier + 1, 3).Hyperlinks.Add Anchor:=Worksheets(“数据库“).Cells(ier + 1, 3), Address:=Worksheets

31、(“数据库“).Cells(ier + 1, 3)ier = ier + 1NextEnd Sub返回 A 列最后一个非空单元行号Sub 返回 A 列最后非空单元行号()MsgBox Cells.Range(“A65536“).End(xlUp).RowEnd Sub返回表中第一个非空单元地址(行搜索)Sub 返回表中第一个非空单元地址()MsgBox Cells.Find(“*“).AddressEnd Sub返回表中各非空单元区域地址(行搜索)Sub 返回表中各非空单元区域地址()MsgBox Cells.SpecialCells(2).AddressEnd Sub返回第一个数值行号Sub

32、 返回第一个数值行号()MsgBox b:b.SpecialCells(2, 1).RowEnd Sub返回第 1 行最右边非空单元的列号Sub 返回第 1 行最右边非空单元的列号()X = IV1.End(xlToLeft).ColumnMsgBox XEnd Sub返回连续数值单元的数量Sub 返回连续数值单元的数量()MsgBox b:b.SpecialCells(2, 1).Rows.CountEnd Sub统计指定范围和内容的单元数量Sub 统计指定范围和内容的单元数量()x = Application.WorksheetFunction.CountIf(Range(“A3:B100

33、“), “总计“)Range(“B1“) = xEnd Sub统计不同颜色的数字的和（自定义函数）Public Function COLOR(ByVal X As Range, Y)For Each I In XIf I.Font.ColorIndex = Y ThenCOLOR = COLOR + IEnd IfNext IEnd Function统计红色,输入：=COLOR(B2:B8,3)统计蓝色,输入：=COLOR(B2:B8,5)返回非空单元数量Sub 返回非空单元数量()x = Application.CountA(Range(“A1:Z65536“)MsgBox xEnd Sub

34、返回 A 列非空单元数量Sub 返回 A 列非空单元数量()y = Application.CountA(Columns(1)MsgBox yEnd Sub返回圆周率 Sub Macro1()Range(“A1“) = Application.Pi()End Sub定义指定单元内容为页眉/页脚Sub 定义指定单元内容为页眉/页脚()BBB = Sheets(“表 1“).Range(“A2“)With ActiveSheet.PageSetup.CenterHeader = BBB 定义页眉 .CenterFooter = BBB 定义页脚End WithEnd Sub提示并全部清除当前选择区

35、域Sub 提示并全部清除当前选择区域()If MsgBox(“你确定要清除选择的区域吗?“, vbYesNo, “ 提示:“) = vbYes Then Selection.ClearEnd Sub全部清除当前选择区域Sub 全部清除当前选择区域()Selection.Clear Range(“A1:B10“).Clear 全部清除指定区域End Sub清除指定区域数值Sub 清除单元数值 ()Sheet1.A1:A10.ClearContentsEnd SubSub 清除指定区域数值()Range(“A1:C8“) = ClearContentsEnd SubSub 清除指定区域数值()Sh

36、eet1.A1:A10=“End Sub对指定工作表执行取消隐藏打印隐藏工作表Sub 打印隐藏工作表()Sheets(“报表 1“).Visible = 1Sheets(“报表 1“).PrintOut Copies:=1, Collate:=TrueSheets(“报表 1“).Visible = 0End Sub打开文件时执行指定宏(工作簿代码)Private Sub Workbook_Open() 重排窗口 要执行的宏名称End Sub返回 A 列最后一个非空单元行号Sub 返回 A 列最后非空单元行号()MsgBox Cells.Range(“A65536“).End(xlUp).Ro

37、wEnd Sub返回表中第一个非空单元地址(行搜索)Sub 返回表中第一个非空单元地址()MsgBox Cells.Find(“*“).AddressEnd Sub返回表中各非空单元区域地址(行搜索)Sub 返回表中各非空单元区域地址()MsgBox Cells.SpecialCells(2).AddressEnd Sub返回第一个数值行号Sub 返回第一个数值行号()MsgBox b:b.SpecialCells(2, 1).RowEnd Sub返回第 1 行最右边非空单元的列号Sub 返回第 1 行最右边非空单元的列号()X = IV1.End(xlToLeft).ColumnMsgBox

38、 XEnd Sub返回连续数值单元的数量Sub 返回连续数值单元的数量()MsgBox b:b.SpecialCells(2, 1).Rows.CountEnd Sub统计指定范围和内容的单元数量Sub 统计指定范围和内容的单元数量()x = Application.WorksheetFunction.CountIf(Range(“A3:B100“), “总计“)Range(“B1“) = xEnd Sub统计不同颜色的数字的和（自定义函数）Public Function COLOR(ByVal X As Range, Y)For Each I In XIf I.Font.ColorIndex

39、 = Y ThenCOLOR = COLOR + IEnd IfNext IEnd Function统计红色,输入：=COLOR(B2:B8,3)统计蓝色,输入：=COLOR(B2:B8,5)返回非空单元数量Sub 返回非空单元数量()x = Application.CountA(Range(“A1:Z65536“)MsgBox xEnd Sub返回 A 列非空单元数量Sub 返回 A 列非空单元数量()y = Application.CountA(Columns(1)MsgBox yEnd Sub返回圆周率 Sub Macro1()Range(“A1“) = Application.Pi()

40、End Sub定义指定单元内容为页眉/页脚Sub 定义指定单元内容为页眉/页脚()BBB = Sheets(“表 1“).Range(“A2“)With ActiveSheet.PageSetup.CenterHeader = BBB 定义页眉 .CenterFooter = BBB 定义页脚End WithEnd Sub提示并全部清除当前选择区域Sub 提示并全部清除当前选择区域()If MsgBox(“你确定要清除选择的区域吗?“, vbYesNo, “ 提示:“) = vbYes Then Selection.ClearEnd Sub全部清除当前选择区域Sub 全部清除当前选择区域()S

41、election.Clear Range(“A1:B10“).Clear 全部清除指定区域End Sub清除指定区域数值Sub 清除单元数值 ()Sheet1.A1:A10.ClearContentsEnd SubSub 清除指定区域数值()Range(“A1:C8“) = ClearContentsEnd SubSub 清除指定区域数值()Sheet1.A1:A10=“End Sub对指定工作表执行取消隐藏打印隐藏工作表Sub 打印隐藏工作表()Sheets(“报表 1“).Visible = 1Sheets(“报表 1“).PrintOut Copies:=1, Collate:=TrueSheets(“报表 1“).Visible = 0End Sub打开文件时执行指定宏(工作簿代码)Private Sub Workbook_Open() 重排窗口 要执行的宏名称End Sub添加自定义序列Sub 添加自定义序列()Application.AddCustomList ListArray:=Array(“优“,“良“, “中“, “差“，“劣“)End Sub弹出打印对话框