excel常用宏集合.doc

65：删除包含固定文本单元的行或列Sub 删除包含固定文本单元的行或列() Do Cells.Find(what:=哈哈).Activate Selection.EntireRow.Delete 删除行 Selection.EntireColumn.Delete 删除列 Loop Until Cells.Find(what:=哈哈) Is NothingEnd Sub 72：在指定颜色区域选择单元时添加/取消（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myrg As Range For Each myrg In Target If myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg , , ) NextEnd Sub 73：在指定区域选择单元时添加/取消（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As Range If Target.Count = 15 Then If Not Application.Intersect(Target, Range(D6:D20) Is Nothing Then For Each Rng In Selection With Rng If .Value = Then .Value = Else .Value = End If End With Next End If End IfEnd Sub 74：双击指定单元，循环录入文本（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)If T.Address $A$1 Then Exit SubCancel = TrueT = IIf(T = 好, 中, IIf(T = 中, 差, 好)End Sub 75：双击指定单元，循环录入文本（工作表代码）Dim nums As BytePrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Target.Address = $A$1 Thennums = nums Mod 3 + 1Target = Mid(上中下, nums, 1)Target.Offset(1, 0).SelectEnd IfEnd Sub 76：单元区域引用（工作表代码）Private Sub Worksheet_Activate()Sheet1.Range(A1:B3).Value = Sheet2.Range(A1:B3).ValueEnd Sub 77：在指定区域选择单元时数值加1（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Application.Intersect(a1:e10, Target) Is Nothing Then Target = Val(Target) + 1 End IfEnd Sub 259个常用宏-excelhome(3) 2009-08-15 14:12:58 78：混合文本的编号Sub 混合文本的编号()Worksheets(1).Range(B2).Value = 北京 (-(Mid(Worksheets(1).Range(B2), 3, 100) + 1)End Sub 79：指定区域单元双击数据累加（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Not Application.Intersect(A1:Y100, Target) Is Nothing Thenoldvalue = Val(Target.Value)inputvalue = InputBox(请输入数量,按ENTER键确认!, 数值累加器)Target.Value = oldvalue + inputvalueEnd IfEnd Sub 80：选择单元区域触发事件（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = $A$1:$B$2 Then MsgBox 你选择了$A$1:$B$2单元End IfEnd Sub 81：当修改指定单元内容时自动执行宏（工作表代码）Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, B3:B4) Is Nothing Then重排窗口End IfEnd Sub 82：被指定单元内容限制执行宏Sub 被指定单元限制执行宏()If Range($A$1) = 关闭 Then Exit Sub窗口End Sub 83：双击单元隐藏该行（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Rows(Target.Row).Hidden = TrueEnd Sub 84：高亮显示行（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = 2Rows(1:2).Interior.ColorIndex = 40 保持1至2行的颜色推荐39,22,40,Rows(Target.Row).Interior.ColorIndex = 35 高亮推荐颜色35,20,24,34,37,40,15End Sub 85：高亮显示行和列（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34Columns(Target.Column).Interior.ColorIndex = 34End Sub 86：为指定工作表设置滚动范围（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Sheet1.ScrollArea = A1:M30End Sub 87：在指定单元记录打印和预览次数（工作簿代码）Private Sub Workbook_BeforePrint(Cancel As Boolean)Range(A1) = 1 + Range(A1)End Sub 88：自动数字金额转大写（工作表代码）Private Sub Worksheet_Change(ByVal M As Range)On Error Resume Nexty = Int(Round(100 * Abs(M) / 100) j = Round(100 * Abs(M) + 0.00001) - y * 100 f = (j / 10 - Int(j / 10) * 10 A = IIf(y 1, , Application.Text(y, DBNum2) 元) b = IIf(j 9.5, Application.Text(Int(j / 10), DBNum2) 角, IIf(y 1, , IIf(f 1, 零, ) c = IIf(f 1, 整, Application.Text(Round(f, 0), DBNum2) 分) M = IIf(Abs(M) 0.005, , IIf(M 0, 负 A b c, A b c)End Sub 89：将所有工作表的A1单元作为单击按钮（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)If Target.Address = $A$1 Then Call 宏名End IfEnd Sub 90：闹钟到指定时间执行宏（工作簿代码）Private Sub Workbook_Open()Application.OnTime (11:45:00), 提示1 宏名字Application.OnTime (12:00:00), 提示2 宏名字End Sub 91：改变Excel界面标题的宏（工作簿代码）Private Sub Workbook_Open()Application.Caption = 春节快乐End Sub 92：在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Worksheets(表2).Range(A1) = Target.Address(0, 0)End Sub 93：B列录入数据时在A列返回记录时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub 94：当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, A1:A1000) Is Nothing ThenIf Target.Column = 1 ThenTarget.Offset(, 1) = DateTarget.Offset(, 2) = TimeEnd IfEnd IfEnd SubPublic Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, A1:A1000) Is Nothing ThenIf Target.Column = 1 ThenTarget.Offset(, 1) = Format(Now(), yyyy-mm-dd)Target.Offset(, 2) = Format(Now(), h:mm:ss)End IfEnd IfEnd Sub 95：指定单元显示光标位置内容（工作表代码）Private Sub Worksheet_SelectionChange(ByVal T As Range)Sheets(1).Range(A1) = SelectionEnd Sub 96：每编辑一个单元保存文件Private Sub Worksheet_Change(ByVal Target As Range)ThisWorkbook.SaveEnd Sub 97：指定允许编辑区域Sub 指定允许编辑区域()ActiveSheet.ScrollArea = B8:G15End Sub 98：解除允许编辑区域限制Sub 解除允许编辑区域限制()ActiveSheet.ScrollArea = End Sub 99：删除指定行Sub 删除指定行()Workbooks(临时表).Sheets(表2).Range(5:5).DeleteEnd Sub 100：删除A列为指定内容的行Sub 删除A列为指定内容的行()Dim a, b As Integera = Sheet1.a65536.End(xlUp).Row For b = a To 2 Step -1 If Cells(b, 1).Value = 删除 Then Rows(b).Delete End If NextEnd Sub 101：删除A列非数字单元行Sub 删除A列非数字单元行()i = a65536.End(xlUp).RowRange(A1:A i).SpecialCells(xlCellTypeConstants, 2).EntireRow.DeleteEnd Sub 102：有条件删除当前行Sub 有条件删除当前行()If A1 = 2 Or B1 = 删除 ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub 103：选择下一行Sub 选择下一行() ActiveCell.Offset(1, 0).Rows(1:1).EntireRow.SelectEnd Sub 104：选择第5行开始所有数据行Sub 选择第5行开始所有数据行A() Dim i% i = Cells.Find(*, SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).EntireRow.Row Rows(5: i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows(5: Cells.Find(*, , , , 1, 2).Row).SelectEnd Sub 105：选择光标或选区所在行Sub 选择光标或选区所在行() Selection.EntireRow.SelectEnd Sub 106：选择光标或选区所在列Sub 选择光标或选区所在列() Selection.EntireColumn.SelectEnd Sub 107：光标定位到名称指定位置Sub 定位()Application.Goto Range(Evaluate(名称)End Sub 108：选择名称定义的数据区Sub 选择名称定义的数据区() 数据区.Select 插入名称要使用INDIRECT函数 Range(数据区).Select 或者 Sheet1.Range(数据区).Select 或者End Sub 109：选择到指定列的最后行Sub 选择到指定列的最后行()Range(C4:G G65536.End(xlUp).Row).SelectEnd Sub 110：将Sheet1的A列的非空值写到Sheet2的A列Sub 将Sheet1的A列的非空值写到Sheet2的A列() Sheet1.Columns(A:A).SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.A1End Sub 111：将名称1的数据写到名称2Sub Macro2()Range(位置2) = Range(位置1).ValueEnd Sub 112：单元反选Sub 单元反选()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress As String, taddress As Stringraddress = Selection.Addresstaddress = ActiveSheet.UsedRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = =0raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address.DeleteEnd WithActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub 113：调整选中对象中的文字Sub 调整选中对象中的文字()文字居中：自动调整大小 With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ReadingOrder = xlContext .Orientation = xlHorizontal .AutoSize = True .AddIndent = False End WithEnd Sub 114：去除指定范围内的对象Sub 去除指定范围内的对象() Dim p As Shape Set My = Worksheets(工作表名) For Each p In My.Shapes If Not Application.Intersect(p.TopLeftCell, Range(范围) Is Nothing Then p.Delete NextEnd Sub 115：更新透视表数据项Sub DeleteMissingItems2002All()防止数据透视表中显示无用的数据项在 Excel 2002 或更高版本中假如无用的数据项已经存在,运行这个宏可以更新Dim pt As PivotTableDim ws As WorksheetFor Each ws In ActiveWorkbook.WorksheetsFor Each pt In ws.PivotTables pt.PivotCache.MissingItemsLimit = xlMissingItemsNoneNext ptNext wsEnd Sub 116：将所有工作表名称写到A列Sub 将所有表名称写到A列()k = 1For Each Sht In SheetsCells(k + 1, 1) = Sht.Name 指定写入的行和列k = k + 1NextEnd Sub 117：为当前选定的多单元插入指定名称Sub 为当前选定的多单元插入指定名称()Selection.Name = 临时ActiveWorkbook.Names.Add Name:=临时, RefersTo:=Selection 或者换用这行代码也可以End Sub 118：删除所有名称Sub 删除所有名称()On Error Resume NextDim l As Integerl = ActiveWorkbook.Names.CountFor i = l To 1 Step -1ActiveWorkbook.Names(i).DeleteNextEnd Sub 119：以指定区域为表目录补充新表Sub 以指定区域为表目录补充新表()Dim dic As Object, sh As WorksheetDim arr, item arr = Range(B1:BB1) Set dic = CreateObject(scripting.dictionary) For Each sh In ThisWorkbook.Worksheets dic.Add sh.Name, Next For Each item In arr If item And Not dic.exists(Trim(item) Then With ThisWorkbook.Worksheets.Add .Name = item End With End If NextSet dic = NothingEnd Sub 120：按A列数据批量修改表名称Sub 按A列数据批量修改表名称() Dim i% For i = 1 To Sheets.Count - 1 Sheets(i).Name = Cells(i + 1, 1).Text NextEnd Sub 121：按A列数据批量创建新表(控件按钮代码)Private Sub CommandButton1_Click()On Error Resume NextDim i%, j%For i = 1 To a65536.End(xlUp).RowFor j = 2 To Sheets.CountIf Cells(i, 1) = Sheets(j).Name ThenExit ForEnd IfNextSheets.Add(after:=Sheets(Sheets.Count).Name = Cells(i, 1)NextEnd Sub 122：清除剪贴板Sub 清除剪贴板() Application.CutCopyMode = False Application.CommandBars(Task Pane).Visible = FalseEnd Sub 123：批量清除软回车Sub 批量清除软回车() 也可直接使用Alt+10或13替换 Cells.Replace What:=Chr(10), Replacement:=, LookAt:=xlPart, SearchOrder:= _ xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=FalseEnd Sub 124：判断指定文件是否已经打开Sub 判断指定文件是否已经打开()Dim x As Integer For x = 1 To Workbooks.Count If Workbooks(x).Name = 函数.xls Then 文件名称 MsgBox 文件已打开 Exit Sub End If Next MsgBox 文件未打开End Sub 125：当前文件另存到指定目录Sub 当前激活文件另存到指定目录()ActiveWorkbook.SaveAs Filename:=E:信件 ActiveWorkbook.NameEnd Sub 126：另存指定文件名Sub 另存指定文件名()ActiveWorkbook.SaveAs ThisWorkbook.Path 别名.xlsEnd Sub 127：以本工作表名称另存文件到当前目录Sub 以本工作表名称另存文件到当前目录()ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path ActiveSheet.Name .xlsEnd Sub 128：将本工作表单独另存文件到Excel当前默认目录Sub 将本工作表单独另存文件到Excel当前默认目录()ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name .xlsEnd Sub 129：以活动工作表名称另存文件到Excel当前默认目录Sub 以活动工作表名称另存文件到Excel当前默认目录() ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name .xls, FileFormat:= _ xlNormal, Password:=, WriteResPassword:=, ReadOnlyRecommended:=False _ , CreateBackup:=FalseEnd Sub 130：另存所有工作表为工作簿Sub 另存所有工作表为工作簿()Dim sht As WorksheetApplication.ScreenUpdating = Falseipath = ThisWorkbook.Path For Each sht In Sheets sht.Copy ActiveWorkbook.SaveAs ipath sht.Name .xls (工作表名称为文件名） ActiveWorkbook.SaveAs ipath sht.Name Trim(sht.d15) .xls （文件名称 D15单元内容） ActiveWorkbook.SaveAs ipath Trim(sht.d15) .xls （文件名称为D15单元内容） ActiveWorkbook.CloseNextApplication.ScreenUpdating = TrueEnd Sub 131：以指定单元内容为新文件名另存文件Sub 以指定单元内容为新文件名另存文件()ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path Sheet1.A1End Sub 132：以当前日期为新文件名另存文件Sub 以当前日期为新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path Format(Now(), yyyymmdd) .xlsEnd SubSub 以当前日期为名称另存文件()ActiveWorkbook.SaveAs Filename:=Date .xlsEnd Sub 133：以当前日期和时间为新文件名另存文件Sub 以当前日期和时间为新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path Format(Now(), yyyy 年 mm 月 dd 日 h 时 mm 分 ss 秒) .xlsEnd Sub 134：另存本表为TXT文件Sub 另存本表为TXT文件() Dim s As String Dim FullName As String, rng As Range Application.ScreenUpdating = False FullName = (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 #1 以读写方式打开文件，每次写内容都会覆盖原先的内容 参考帮助，fullname为文件全名 For Each rng In Range(a1).CurrentRegion s = s IIf(s = , , |) rng.Value If rng.Column = Range(a1).CurrentRegion.Columns.Count Then Print #1, s | 把数据写到文本文件里 s = End If Next Close #1 关闭文件 Application.ScreenUpdating = True MsgBox 数据已导入文本End Sub 135：引用指定位置单元内容为部分文件名另存文件Sub 引用指定位置单元内容为部分文件名另存文件()ActiveWorkbook.SaveAs Filename:=E:信件 解答 Range(sheet1!a1) 郎雀.xlsEnd Sub 136：将A列数据排序到D列Sub 将A列数据排序到D列()d:d = a:a.Valued:d.Sort Key1:=Range(D1), Order1:=xlAscending, Header:=xlYesEnd Sub 137：将指定范围的数据排列到D列Sub 将指定范围的数据排列到D列()Dim arr1, arr2, i%, 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 138：光标所在行上移一行Sub 光标所在行上移一行() Dim i% i = Split(ActiveCell.Address, $)(2) If i 1 Then Rows(i).Cut Rows(i - 1).Insert Shift:=xlDown End IfEnd Sub 139：加数据有效限制Sub 加数据有效限制() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:= .IgnoreBlank = False .InCellDropdown = False .InputTitle = .ErrorTitle = .InputMessage = .ErrorMessage = 要奋斗就会有牺牲，死人的事是经常发生的。 .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End WithEnd Sub 140：取消数据有效限制Sub 取消数据有效限制() With Selection.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = False .InCellDropdown = False .InputTitle = .ErrorTitle = .InputMessage = .ErrorMessage = .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End WithEnd Sub 141：重排窗口Sub 重排窗口() Application.CommandBars(Web).Visible = False Application.CommandBars(我的工具).Visible = False Windows.Arrange ArrangeStyle:=xlCascadeEnd Sub 142：按当前单元文本选择打开指定文件单元Sub 选择打开文件单元() Dim a a = ActiveCell.Value Range(a).Worksheet.Activate Range(a).SelectEnd Sub 143：回车光标向右Sub 录入光标向右() Application.MoveAfterReturnDirection = xlToRightEnd Sub 144：回车光标向下Sub 录入光标向下() Application.MoveAfterReturnDirection = xlDownEnd Sub 145：保护工作表时取消选定锁定单元Sub 取消选定锁定单元() ActiveSheet.EnableSelection = xlUnlockedCells 用于2000版End Sub 146：保存并退出ExcelSub 保存并退出Excel()Application.SendKeys (ENTERENTER%fx)ActiveWorkbook.SaveEnd Sub 147：隐藏/显示指定列空值行Sub 隐藏显示E列空值行()Range(E1:E1000).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = Not (Range(E1:E1000).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden)End Sub 148：深度隐藏指定工作表Sub 深度隐藏指定工作表()Sheets(用户名密码).Visible = xlVeryHiddenEnd Sub 149：隐藏指定工作表Sub 隐藏指定工作表()Sheets(用户名密码).Visible = falseEnd Sub 150：隐藏当前工作表Sub 隐藏当前工作表() ActiveWindow.SelectedSheets.Visible = falseEnd Sub 151：返回当前工作表名称Sub 返回当前工作表名称()wsName = ActiveSheet.NameMsgBox 当前工作表为： wsNameEnd Sub 152：获取上一次所进入工作簿的工作表名称Sub 获取上一次所进入工作簿的工作表名称()MsgBox Workbooks(2).ActiveSheet.NameEnd Sub 153：按光标选定颜色隐藏本列其他颜色行Sub 按颜色筛选() 思路就是:其它背景色之行所有隐藏Dim UseRow, AC, i 首先选择一个有颜色之单元格，然后动行宏，其它颜色所在行隐藏UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格If ActiveCell.Row UseRow ThenMsgBox 请在要筛选的区域选择一个有颜色之单元格！, vbExclamation, 错误ElseAC = ActiveCell.ColumnCells.EntireRow.Hidden = False 显示所有行For i = 2 To UseRowIf Cells(i, AC).Interior.ColorIndex ActiveCell.Interior.ColorIndex ThenCells(i, AC).EntireRow.Hidden = True 假如2至已用行之单元格的有列之颜色不等于当前单元格颜色则隐藏整行End IfNextEnd IfEnd Sub 154：打开工作簿自动隐藏录入表以外的其他表Private Sub Workbook_Open()Dim iFor i = 1 To Sheets.CountIf Sheets(i).Name 录入 ThenSheets(i).Visible = FalseEnd IfNextEnd Sub 155：除最左边工作表外深度隐藏所有表Sub 除最左边工作表外深度隐藏所