EXCEL宏代码大全
EXCEL宏代码大全
EXCEL宏代码大全本文件部分文章来源于网络000. A列半角内容变红Sub A列半角内容变红() ? Dim rg As Range, i As Long ? Application.ScreenUpdating = False ? For Each rg In Cells.SpecialCells(xlCellTypeConstants, 3) For i = 1 To Len(rg) If Asc(Mid(rg, i, 1))001. A列等于A列减B列Sub A列等于A列减B列() For i = 1 To 23 Cells(i, 1) = Cells(i, 1) - Cells(i, 2) Next End Sub002. B列录入数据时在A列返回记录时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then Target.Offset(, -1) = Now End If End Sub003. Excel宏常用代码本大类暂没有内容，以下是关于本类的所有记录集。
004. Sub 以当前日期为名称另存文件()ActiveWorkbook.SaveAs Filename:=Date & ".xls" End Sub005. Sub 启用保存()mandBars("File").Controls(4).Enabled = True mandBars("File").Controls(5).Enabled = True End Sub006. Sub 执行前需要验证密码的宏()If InputBox("请输入您的使用权限:", "系统提示") = 123 Then 重排窗口 ''要执行的宏代码或宏名称 Else MsgBox "对不起,您没有使用该宏的权限,按确定键后退出!" End If End Sub007. Sub 选择第5行开始所有数据行B()Rows("5:" & Cells.Find("*", , , , 1, 2).Row).Select End Sub008. VBA返回公式结果Sub VBA返回公式结果() x = Application.WorksheetFunction.Sum(Range("a2:a100"))Range("B1") = x End Sub009. 不连续区域录入对勾Sub 批量录入对勾() Selection.FormulaR1C1 = "√" End Sub010. 不连续区域录入当前单元地址Sub 区域录入当前单元地址() For Each mycell In Selection mycell.FormulaR1C1 = mycell.Address Next End Sub011. 不连续区域录入当前数字日期Sub 区域录入当前数字日期() Selection.FormulaR1C1 = Format(Now(), "yyyymmdd") End Sub012. 不连续区域录入当前文件名Sub 批量录入当前文件名() Selection.FormulaR1C1 = End Sub013. 不连续区域录入当前日期Sub 区域录入当前日期() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d") End Sub014. 不连续区域录入当前日期和时间Sub 区域录入当前日期和时间() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss") End Sub015. 不连续区域插入当前文件名和表名及地址Sub 批量插入当前文件名和表名及地址() For Each mycell In Selection mycell.FormulaR1C1 = "[" + + "]" + + "!" + mycell.Address Next End Sub016. 不连续区域插入文本Sub 批量插入文本() Dim s As Range For Each s In Selection s = "文本内容" & s Next End Sub017. 不连续区域添加文本Sub 批量添加文本() Dim s As Range For Each s In Selection s = s & "文本内容" Next End Sub018. 为当前选定的多单元插入指定名称Sub 为当前选定的多单元插入指定名称() = "临时" s.Add Name:="临时", RefersT o:=Selection ''或者换用这行代码也可以 End Sub019. 为指定工作表加指定密码保护表Sub 为指定工作表加指定密码保护表() Sheet10.Protect Password:="123" End Sub020. 为指定工作表设置滚动范围（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Sheet1.ScrollArea = "A1:M30" EndSub021. 从指定位置向下同时录入多单元指定内容Sub 从指定位置向下同时录入多单元指定内容() Dim arr arr = Array("1", "2", "13", "25", "46", "12", "0", "20") [B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr) End Sub022. 以A1单元内容批量插入批注Sub 以A1单元内容批量插入批注() Dim r As Range If Selection.Cells.Count > 0 Then For Each r In Selection r.AddComment ment.Visible = False ment.Text Text:=[a1].T ext Next End If End Sub023. 以A1单元文本作表名插入工作表Sub 以A1单元文本作表名插入工作表() Dim nm As String nm = [a1] Sheets.Add = nm End Sub024. 以当前日期为新文件名另存文件Sub 以当前日期为新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls" End Sub025. 以当前日期和时间为新文件名另存文件Sub 以当前日期和时间为新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls" End Sub026. 以指定区域为表目录补充新表Sub 以指定区域为表目录补充新表() Dim dic As Object, sh AsWorksheet Dim arr, item arr = Range("B1:BB1") Set dic = CreateObject("scripting.dictionary") For Each sh In ThisWorkbook.Worksheets dic.Add ,027. 以指定单元内容为新文件名另存文件Sub 以指定单元内容为新文件名另存文件() ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.[A1] End Sub028. 以本工作表名称另存文件到当前目录Sub 以本工作表名称另存文件到当前目录() ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & & ".xls" End Sub029. 以活动工作表名称另存文件到Excel当前默认目录Sub 以活动工作表名称另存文件到Excel当前默认目录() ActiveWorkbook.SaveAs Filename:= & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=030. 使单元内容保持不变的工作表代码Private Sub Worksheet_Change(ByVal Target As Range) [B2] = "不可更改的数据" End Sub031. 保存并退出ExcelSub 保存并退出Excel() Application.SendKeys ("{ENTER}{ENTER}%fx") ActiveWorkbook.Save End Sub032. 保护工作表时取消选定锁定单元Sub 取消选定锁定单元() ActiveSheet.EnableSelection =xlUnlockedCells ''用于2000版 End Sub033. 光标定位到名称指定位置Sub 定位() Application.Goto Range(Evaluate("名称")) End Sub034. 光标定位到指定工作表A列最后数据行下一单元Sub 光标定位到指定工作表A列最后数据行下一单元() a = Sheets("数据库").[a65536].End(xlUp).Row Sheets("数据库").Select Range("A" & a + 1).Select End Sub035. 光标所在行上移一行Sub 光标所在行上移一行() Dim i% i = Split(ActiveCell.Address, "$")(2) If i > 1 Then Rows(i).Cut Rows(i - 1).Insert Shift:=xlDown End If End Sub036. 光标移动Sub 光标移动() ActiveCell.Offset(1, 2).Select ''向下移动1行，向右移动2列 End Sub037. 全选固定范围内小于0的单元Sub 全选固定范围内小于0的单元() Dim rng As Range Dim yvhf For Each rng In Range("d6: i18") If rng < 0 Then yvhf = yvhf & rng.Address & "," End If Next Range(Left(yvhf, Len(yvhf) - 1)).Select End Sub038. 全选选定范围内小于0的单元Sub 全选选定范围内小于0的单元() Dim rng As Range Dim yvhf For Each rng In Selection If rng < 0 Then yvhf = yvhf & rng.Address & "," End If Next Range(Left(yvhf, Len(yvhf) - 1)).Select End Sub039. 全部显示指定表的自动筛选Sub 全部显示指定表的自动筛选() If Sheet1.FilterMode = True Then Sheet1.ShowAllData End If End Sub040. 全部清除当前选择区域Sub 全部清除当前选择区域() Selection.Clear '' Range("A1:B10").Clear ''全部清除指定区域 End Sub041. 关闭文件时执行指定宏(工作簿代码)Private Sub Workbook_BeforeClose(Cancel As Boolean) 重排窗口 ''要执行的宏名称 End Sub042. 关闭文件时自动隐藏指定工作表(ThisWorkbook)Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Unprotect Sheets("Sheet2").Visible = False Sheets("Sheet3").Visible = False ActiveWorkbook.Protect Structure:=True, Windows:=Fal043. 分离临时表A列数据的文本和超链接并会同其他数据整理到数据库表Sub 分离A列数据的文本和超链接并会同其他数据整理到指定表() ier = Worksheets("数据库").Range("b60000").End(xlUp).Row For ee = 5 To Range("a60000").End(xlUp).Row For Each hh In Worksheets("临时").Hyperlinks If hh.T extToDisplay =044. 分离临时表A列数据的文本和超链接并整理到数据库表Sub 分离A列中的超链接到指定表的B和C列() i = Worksheets("数据库").Range("b60000").End(xlUp).Row For Each h In Worksheets("临时").Hyperlinks Worksheets("数据库").Cells(i + 1, 2)= h.TextT oDisplay Worksheets("数据库").Cells(045. 删除A列为指定内容的行Sub 删除A列为指定内容的行() Dim a, b As Integer a = Sheet1.[a65536].End(xlUp).Row For b = a To 2 Step -1 If Cells(b, 1).Value = "删除" Then Rows(b).Delete End If Next End Sub046. 删除A列空行Sub 删除A列空行() Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub047. 删除A列非数字单元行Sub 删除A列非数字单元行() i = [a65536].End(xlUp).Row Range("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End Sub048. 删除B列数据的超链接Sub 删除超链接() For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)Sheet1.Range(Rng.Address).Hyperlinks.Delete Next End Sub049. 删除全部名称Sub 删除全部名称() On Error Resume Next Dim l As Integer l = s.Count For i = l T o 1 Step -1 s(i).Delete Next End Sub050. 删除全部未选定工作表Sub 删除全部未选定工作表() Dim sht As Worksheet, n As Integer, iFlag As Boolean Dim ShtName() As String n =ActiveWindow.SelectedSheets.Count ReDim ShtName(1 To n) n = 1 For Each sht In ActiveWindow.Selec051. 删除包含固定文本单元的行或列Sub 删除包含固定文本单元的行或列() Do Cells.Find(what:="哈哈").Activate Selection.EntireRow.Delete ''删除行 '' Selection.EntireColumn.Delete ''删除列 Loop Until Cells.Find(what:="哈哈") Is Nothing End Sub052. 删除指定文件Sub 删除指定文件() Kill "E:\信件\1.xls" End Sub053. 删除指定行Sub 删除指定行() Workbooks("临时表").Sheets("表2").Range("5:5").Delete End Sub054. 判断指定文件是否已经打开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 Sub055. 加数据有效限制Sub 加数据有效限制() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="******************".IgnoreBlank = False .InCellDropd056. 单元区域引用（工作表代码）Private Sub Worksheet_Activate()Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").Value End Sub057. 单元反选Sub 单元反选() Application.DisplayAlerts = False Application.ScreenUpdating = False Dim raddress As String, taddress As String raddress = Selection.Address taddress = edRange.Address058. 单元格录入1位字符就跳转(工作表代码)Private Sub TextBox1_Change() If Len(Me.TextBox1.Text) <> 1 Then Exit Sub Me.TextBox1.Activate ActiveCell = Me.TextBox1.Text Me.TextBox1.Text = "" ActiveCell.Activate Application.SendKeys "~"059. 单元格录入数据时运行宏的代码Private Sub Worksheet_Change(ByVal Target As Range) 重排窗口 End Sub060. 去除指定范围内的对象Sub 去除指定范围内的对象() ??Dim p As Shape Set My = Worksheets("工作表名") For Each p In My.Shapes If Not Application.Intersect(p.T opLeftCell, Range("范围")) Is Nothing Then p.Delete Next061. 双击单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Range("$A$1") = "关闭" Then Exit Sub Select Case T arget.Address Case "$A$4" Call 宏1 Cancel = True Case "$B$4"062. 双击单元隐藏该行（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Rows(Target.Row).Hidden = True End Sub063. 双击指定区域单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Range("$A$1") = "关闭" Then Exit Sub If Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then064. 双击指定单元，循环录入文本（工作表代码）Dim nums As Byte Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address = "$A$1" Then nums = nums Mod 3 + 1 Target = Mid("上中下", nums, 1) T arget.Offse065. 反方向文本(自定义函数)Function zhyz(zhyz1 As Range) zhyz = StrReverse(zhyz1) End Function 将代码复制到模块后单元公式：=zhyz(单元格)066. 取消指定行或列的隐藏Sub 取消隐藏行() Rows("3:5").Select Selection.EntireRow.Hidden = False End Sub Sub 取消隐藏列() Columns("C:F").Select Selection.EntireColumn.Hidden = False End Sub067. 取消数据有效限制Sub 取消数据有效限制() WithSelection.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = False .InCellDropdown = False .InputTitle =068. 取消自动筛选()Sub 取消自动筛选() ActiveSheet.AutoFilterMode = False End Sub069. 取消选定区域的公式只保留值(假空转真空)Sub 取消选定区域的公式只保留值() ?''?? Sheets("数据归并集中").Select ''指定工作表 ?''?? Columns("Q:R").Select ''指定范围 Selection.Value = Selection.Value End Sub070. 另存所有工作表为工作簿Sub 另存所有工作表为工作簿() Dim sht As Worksheet Application.ScreenUpdating = False ipath = ThisWorkbook.Path & "\" For Each sht In Sheets sht.Copy ActiveWorkbook.SaveAs ipath & & ".xls" ''(工作表名071. 另存指定文件名Sub 另存指定文件名() ActiveWorkbook.SaveAs ThisWorkbook.Path & "\别名.xls" End Sub072. 另存本表为TXT文件Sub 另存本表为TXT文件() Dim s As String Dim FullName As String, rng As Range Application.ScreenUpdating = False FullName = ( & ".txt") ''以当前表名为TXT文件名 '' FullName = Replace(ThisWorkboo073. 右侧单元自动加5(工作表代码)Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target.Offset(0, 1) = T arget + 5 Application.EnableEvents = True End Sub074. 合并A1至C1的内容写到D15单元的批注中‘/dispbbs.asp?boardid=2&id=251887 northwolves版主 Sub 将A1至C1的内容写到D15单元的批注中() [iv1:iv12] = "=rc1 & "" ""& rc2 &"" ""& rc3" [d15].AddComment Join(Application.Transpose([iv1:i075. 合并各工作表内容Sub 合并各工作表内容() sp = InputBox("各表内容之间，间隔几行？不输则默认为0") If sp = "" Then sp = 0 End If st = InputBox("各表从第几行开始合并？不输则默认为2") If st = "" Then st = 2 End If Sheets(1).Select Sheets.Add If st076. 合并指定目录中所有文件中相同格式工作表的数据Sub 合并数据() ''合并指定目录中所有文件中相同格式工作表的数据 ''见/dispbbs.asp?boardid=1&replyid=900613&id=249319&page=1 &skin=0&Star=2帖11楼eq800的代码 Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i077. 回车光标向下Sub 录入光标向下() Application.MoveAfterReturnDirection = xlDown End Sub078. 回车光标向右Sub 录入光标向右() Application.MoveAfterReturnDirection =xlToRight End Sub079. 固定区域单元分类变色Sub 单元分类变色() Dim rng As Range For Each rng In Range("d6: i18") If rng < 0 Then rng.Interior.ColorIndex = 4 ''小于0的单元变绿底色 End If Next For Each rng In Range("d6: i18") If rng > 0 Then rng.080. 在A1返回当前选中单元格数量Sub 在A1返回当前选中单元格数量() [A1] = Selection.Count End Sub081. 在A列产生不重复随机数Sub 在A列产生不重复随机数() Randomize Timer Dim c(100) As Byte For i = 1 To 100 ''产生100个随机数 c(i) = i Next k = 100 Do While l < 100 r = Int(Rnd() * k) + 1 ''随机数的范围 aa = c(r) c(r) = c(k) c(k) = aa k =082. 在A和B列返回当前选区的名称和公式Sub 在A和B列返回当前选区的名称和公式() [a1].ListNames End Sub083. 在F1单元显示光标位置批注内容的代码Private Sub Worksheet_SelectionChange(ByVal Target As Range) a = Selection.Address b = Range(a).NoteText Cells(1, 6) = b End Sub084. 在M和N列的14行以下选择单元时显示调用日历控件（工作表代码）Private Sub Calendar1_Click() With Calendar1 ActiveCell= .Value .Visible = False End With End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 13 And Target085. 在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Option Explicit Private Sub CommandButton1_Click() With CommandButton1 If .Caption = "宏1" Then Call 宏1 .Caption = "宏2" Exit Sub End If If .Caption = "宏2" Then Call 宏2 .Caption = "宏3" Exit S086. 在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Private Sub CommandButton1_Click() With CommandButton1 If .Caption = "保护工作表" Then Call 保护工作表 .Caption = "取消工作表保护" Exit Sub End If If .Caption = "取消工作表保护" Then Call 取消工作表保护 .Caption = "保护工作表"087. 在多个宏中依次循环执行一个（控件按钮代码）Private Sub CommandButton1_Click() Static RunMacro As Integer Select Case RunMacro Case 0 宏1 RunMacro = 1 Case 1 宏2 RunMacro = 2 Case 2 宏3 RunMacro = 0 End Select End Sub088. 在当前工作组各表中分别执行指定宏''northwolves版主解答 /dispbbs.asp?boardid=2&id=251426&star=2#914934 Sub 在当前工作组各表中分别执行指定宏() Dim SH As Worksheet For Each SH In ActiveWindow.SelectedSheets SH.Activate 临时 N089. 在当前选区有条件替换数值为文本Sub 在当前选区有条件替换数值为文本() For Each r In Selection If r.Value > 18 And r.Value < 29.5 Then r.Value = "Y" Next End Sub090. 在所有工作表的A1单元返回顺序号Sub 在所有工作表的A1单元返回顺序号() For i = 1 T o Sheets.Count Sheets(i).Cells(1, 1) = "''" & Application.WorksheetFunction.Text(0 + i, "000") Next End Sub091. 在指定区域选择单元时数值加1（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Application.Intersect([a1:e10], Target) Is Nothing Then Target = Val(Target) + 1 End If End Sub092. 在指定单元记录打印和预览次数（工作簿代码）Private Sub Workbook_BeforePrint(Cancel As Boolean) Range("A1") = 1 + Range("A1") End Sub093. 在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Worksheets("表2").Range("A1") = Target.Address(0, 0) End Sub094. 在有密码的工作表执行代码Sub 在有密码的工作表执行代码() Sheets("1").Unprotect Password:=123 ''假定表名为“1”，密码为“123”打开工作表 Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True ''隐藏C列空值行 Sheets("1").Protect Password:=123095. 在目录表建立本工作簿中各表链接目录Sub 在目录表建立本工作簿中各表链接目录() Dim s%, Rng As Range On Error Resume Next Sheets("目录").Activate If Err = 0 Then Sheets("目录").UsedRange.Delete Else Sheets.Add = "目录" End If For i =096. 在第一个表前插入多工作表Sub 在第一个表前插入多工作表() Sheets(1).Select For I = 1 To 50 = "新表" & I Next End Sub097. 填公式Sub 填公式() Range("C2:C12").Value = "=SUM(A2:B2)" End Sub098. 处理导入的显示为科学计数法样式的身份证号Sub 处理导入的显示为科学计数法样式的身份证号() Selection.Value = Selection.Formula End Sub099. 复制单元数值Sub 复制数值() s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2") Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = s End Sub100. 复制单元格所在列Sub 复制单元格所在列() Selection.EntireColumn.Copy End Sub101. 复制单元格所在行Sub 复制单元格所在行() Selection.EntireRow.Copy End Sub102. 复制当前工作簿的报表到临时工作簿Sub 复制当前工作簿的报表到临时工作簿() ''作者：yuanzhuping 版主 Dim x As Integer Dim sht As Worksheet On Error Resume Next For x = 1 To Workbooks.Count If Workbooks(x).Name = "临时.xls" Then For Each sht In Workbook103. 奇偶页分别打印Sub 奇偶页分别打印() Dim i%, Ps% Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") ''总页数 MsgBox "现在打印奇数页,按确定开始." For i = 1 To Ps Step 2 ActiveSheet.PrintOut from:=i, To:=i Next i MsgBox "现在打印偶数页,按确定开始." For104. 定义指定工作表标签颜色Sub 定义指定工作表标签颜色() Sheets("Sheet1").T ab.ColorIndex = 46 End Sub105. 定位数据及区域以上的空值Sub 定位数据及区域以上的空值() Dim aa As Range For Each a In edRange If a Like〈0 Then If aa Is Nothing Then Set aa = a.Cells Else Set aa = Union(aa, a.Cells) End If End If Next aa.Select106. 定位选定单元格式相同的全部单元格Sub 定位选定单元格式相同的全部单元格() Dim FirstCell As Range, FoundCell As Range Dim AllCells As Range With Application.FindFormat .Clear .NumberFormatLocal = Selection.NumberFormatLocal .HorizontalAlignment =107. 实现删去特定的行Sub test() For Each i In ThisWorkbook.Worksheets(1).range("E:E") If i.Value = "32766" Then Rows(i.Row).Delete End If Next i End Sub ''用的是第一张工作表，可以按需要改Worksheets(1)为指定的工作表。
实用excel宏代码(精华版)
非常实用excel宏代码代码功能包含：显示所有隐藏工作表，按指定列拆分工作表，将一个工作簿内的多个工作表拆分为一个个独立的工作簿，在工作簿打开的状态下直接重命名活动工作簿，工作表保护密码破解，一次性关闭所有工作簿，将所选单元格数值单位转换为万显示，一次性提取所有工作表名称等--------------------------------------------------Sub 显示所有隐藏工作表()For Each St In SheetsIf St.Visible = False Then St.Visible = True NextEnd Sub-------------------------------------------Sub 按指定列拆分工作表()Dim i%, m%, h$h = Range("a1").Selectm = InputBox("请输入列数")Columns(m).CopyWorksheets.Add After:=Sheets(Sheets.Count) = "B"Range("A1").SelectActiveSheet.PasteRange("A:A").RemoveDuplicates (1)Sheets("B").Visible = FalseFor i = 2 To Application.WorksheetFunction.CountA(Sheets("B").Range(" A:A"))Sheets(h).ActivateedRange.AutoFilter Field:=m, Criteria1:=Sheets("B").Cells(i, 1)Sheets(h).UsedRange.CopySheets.Add After:=Sheets(Sheets.Count)ActiveSheet.Paste = Sheets("B").Cells(i, 1)Sheets(h).SelectNextSelection.AutoFilterApplication.DisplayAlerts = FalseSheets("B").DeleteApplication.DisplayAlerts = TrueEnd Sub----------------------------------------Sub 重命名活动工作簿()'如果利用DIR提取的活动工作簿的名称长度为0(即未保存)，那么提示用户，然后退出程序If Len(Dir(ActiveWorkbook.FullName)) = 0 Then MsgBox "请先保存工作簿", vbOKOnly, "友情提示": Exit Sub Dim 原名称As String, 新名称As String, 后缀名As String, 路径As String '声明变量原名称= '提取活动工作簿名称后缀名= StrReverse(Mid(StrReverse(原名称), 1, InStr(StrReverse(原名称), "."))) '提取活动工作簿的后缀名新名称= Application.InputBox("请输入文件名", "新名称", Replace(原名称, 后缀名, ""), , , , , 2) '弹出输入框让用户输入新的名称If 新名称= "False" Then End '如果选择了取消键则结束过程路径= Replace(ActiveWorkbook.FullName, 原名称, "") '提取活动工作簿的路径On Error Resume Next '当有错误时继续执行MkDir "C:\" & 新名称'在C盘创建一个同名的文件夹(测试字符串能否作为文件名称)If Err <> 0 Then '如果有错误MsgBox "您输入的字符不允许作为文件名，请重新输入！", vbOKOnly, "友情提示" '提示Else'否则RmDir "C:\" & 新名称'删除创建的文件夹ActiveWorkbook.SaveAs 路径& 新名称& 后缀名'将活动工作簿另存为指定的名称(与原文件相同路径下)Kill 路径& 原名称'删除原来的文件End IfEnd Sub---------------------------------------------------Public Sub 工作表保护密码破解()Const DBLSPACE As String = vbNewLine & vbNewLine Const AUTHORS As String = DBLSPACE & vbNewLine & _ "作者:McCormick JE McGimpsey "Const HEADER As String = "工作表保护密码破解"Const VERSION As String = DBLSPACE & "版本Version 1.1.1"Const REPBACK As String = DBLSPACE & ""Const ZHENGLI As String = DBLSPACE & " hfhzi3—戊冥整理"Const ALLCLEAR As String = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _& DBLSPACE & "注意：不要用在不当地方，要尊重他人的劳动成果！"Const MSGNOPWORDS1 As String = "该文件工作表中没有加密"Const MSGNOPWORDS2 As String = "该文件工作表中没有加密2"Const MSGTAKETIME As String = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!"Const MSGPWORDFOUND1 As String = "密码重新组合为:"& DBLSPACE & "$$" & DBLSPACE & _"如果该文件工作表有不同密码,将搜索下一组密码并修改清除"Const MSGPWORDFOUND2 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _"如果该文件工作表有不同密码,将搜索下一组密码并解除" Const MSGONLYONE As String = "确保为唯一的?"Dim w1 As Worksheet, w2 As WorksheetDim i As Integer, j As Integer, k As Integer, l As IntegerDim m As Integer, n As Integer, i1 As Integer, i2 As Integer Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer Dim PWord1 As StringDim ShTag As Boolean, WinTag As BooleanApplication.ScreenUpdating = FalseWith ActiveWorkbookWinTag = .ProtectStructure Or .ProtectWindowsEnd WithShTag = FalseFor Each w1 In WorksheetsShTag = ShTag Or w1.ProtectContentsNext w1If Not ShTag And Not WinTag ThenMsgBox MSGNOPWORDS1, vbInformation, HEADER Exit SubEnd IfMsgBox MSGTAKETIME, vbInformation, HEADERIf Not WinTag ThenElseOn Error Resume NextDo 'dummy do loopFor i = 65 To 66: For j = 65 To 66: For k = 65 To 66For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 With ActiveWorkbook.Unprotect Chr(i) & Chr(j) & Chr(k) & _Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)If .ProtectStructure = False And _.ProtectWindows = False ThenPWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)MsgBox Application.Substitute(MSGPWORDFOUND1, _"$$", PWord1), vbInformation, HEADERExit Do 'Bypass all for...nextsEnd IfEnd WithNext: Next: Next: Next: Next: NextNext: Next: Next: Next: Next: NextLoop Until TrueOn Error GoTo 0End IfIf WinTag And Not ShTag ThenMsgBox MSGONLYONE, vbInformation, HEADER Exit SubEnd IfOn Error Resume NextFor Each w1 In Worksheets'Attempt clearance with PWord1w1.Unprotect PWord1Next w1On Error GoTo 0ShTag = FalseFor Each w1 In Worksheets'Checks for all clear ShTag triggered to 1 if not.ShTag = ShTag Or w1.ProtectContentsNext w1If ShTag ThenFor Each w1 In WorksheetsWith w1If .ProtectContents ThenOn Error Resume NextDo 'Dummy do loopFor i = 65 To 66: For j = 65 To 66: For k = 65 To 66For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 .Unprotect Chr(i) & Chr(j) & Chr(k) & _Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)If Not .ProtectContents ThenPWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)MsgBox Application.Substitute(MSGPWORDFOUND2, _ "$$", PWord1), vbInformation, HEADER'leverage finding Pword by trying on other sheetsFor Each w2 In Worksheetsw2.Unprotect PWord1Next w2Exit Do 'Bypass all for...nextsEnd IfNext: Next: Next: Next: Next: NextNext: Next: Next: Next: Next: NextLoop Until TrueOn Error GoTo 0End IfEnd WithNext w1End IfMsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK & ZHENGLI, vbInformation, HEADEREnd Sub---------------------------------------------------Sub 关闭所有工作簿()Application.DisplayAlerts = FalseWorkbooks.CloseApplication.DisplayAlerts = TrueEnd Sub--------------------------------------------------- Sub 将一个工作簿内的多个工作表拆分为一个个独立的工作簿()Application.DisplayAlerts = FalseDim sht As WorksheetDim MyBook As WorkbookSet MyBook = ActiveWorkbookFor Each sht In MyBook.Sheetssht.CopyActiveWorkbook.SaveAsFileName:=MyBook.Path & "\" & , FileFormat:=xlNormal '将工作簿另存为EXCEL默认格式ActiveWorkbook.CloseNextApplication.DisplayAlerts = TrueMsgBox "文件已经被分拆完毕!"End Sub---------------------------------------------------Sub 所选单元格数值单位转换为万显示()'' 格式万宏'' 快捷键: Ctrl+Shift+ZSelection.NumberFormatLocal = "0!.0,万"End Sub--------------------------------------------------- Sub 提取所有工作表名称()Dim xFor x = 1 To Sheets.CountCells(x, 1) = Sheets(x).NameNext xEnd Sub。
excel常用宏集合
65：删除包含固定文本单元的行或列Sub 删除包含固定文本单元的行或列()DoCells.Find(what:="哈哈").ActivateSelection.EntireRow.Delete '删除行' Selection.EntireColumn.Delete '删除列Loop Until Cells.Find(what:="哈哈") Is NothingEnd Sub72：在指定颜色区域选择单元时添加/取消"√"（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> "√", "√", "") NextEnd Sub73：在指定区域选择单元时添加/取消"√"（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target, Range("D6:D20")) Is Nothing Then For Each Rng In SelectionWith RngIf .Value = "" Then.Value = "√"Else.Value = ""End IfEnd WithNextEnd IfEnd IfEnd Sub74：双击指定单元，循环录入文本（工作表代码）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 Sub75：双击指定单元，循环录入文本（工作表代码）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 Sub76：单元区域引用（工作表代码）Private Sub Worksheet_Activate()Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").ValueEnd Sub77：在指定区域选择单元时数值加1（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect([a1:e10], Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub259个常用宏-excelhome(3)2009-08-15 14:12:5878：混合文本的编号Sub 混合文本的编号()Worksheets(1).Range("B2").Value = "" & (--(Mid(Worksheets(1).Range("B2"), 3, 100))+ 1)End Sub79：指定区域单元双击数据累加（工作表代码）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 Sub80：选择单元区域触发事件（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = "$A$1:$B$2" ThenMsgBox "你选择了$A$1:$B$2单元"End IfEnd Sub81：当修改指定单元容时自动执行宏（工作表代码）Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then重排窗口End IfEnd Sub82：被指定单元容限制执行宏Sub 被指定单元限制执行宏()If Range("$A$1") = "关闭" Then Exit Sub窗口End Sub83：双击单元隐藏该行（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Rows(Target.Row).Hidden = TrueEnd Sub84：高亮显示行（工作表代码）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 Sub85：高亮显示行和列（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34Columns(Target.Column).Interior.ColorIndex = 34End Sub86：为指定工作表设置滚动围（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Sheet1.ScrollArea = "A1:M30"End Sub87：在指定单元记录打印和预览次数（工作簿代码）Private Sub Workbook_BeforePrint(Cancel As Boolean)Range("A1") = 1 + Range("A1")End Sub88：自动数字金额转大写（工作表代码）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 * 100f = (j / 10 - Int(j / 10)) * 10A = 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 Sub89：将所有工作表的A1单元作为单击按钮（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)If Target.Address = "$A$1" ThenCall 宏名End IfEnd Sub90：闹钟——到指定时间执行宏（工作簿代码）Private Sub Workbook_Open()Application.OnTime ("11:45:00"), "提示1" '宏名字Application.OnTime ("12:00:00"), "提示2" '宏名字End Sub91：改变Excel界面标题的宏（工作簿代码）Private Sub Workbook_Open()Application.Caption = "春节快乐"End Sub92：在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Worksheets("表2").Range("A1") = Target.Address(0, 0)End Sub93：B列录入数据时在A列返回记录时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub94：当指定区域修改时在其右侧的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 Sub95：指定单元显示光标位置容（工作表代码）Private Sub Worksheet_SelectionChange(ByVal T As Range)Sheets(1).Range("A1") = SelectionEnd Sub96：每编辑一个单元保存文件Private Sub Worksheet_Change(ByVal Target As Range)ThisWorkbook.SaveEnd Sub97：指定允许编辑区域Sub 指定允许编辑区域()ActiveSheet.ScrollArea = "B8:G15"End Sub98：解除允许编辑区域限制Sub 解除允许编辑区域限制()ActiveSheet.ScrollArea = ""End Sub99：删除指定行Sub 删除指定行()Workbooks("临时表").Sheets("表2").Range("5:5").DeleteEnd Sub100：删除A列为指定容的行Sub 删除A列为指定容的行()Dim a, b As Integera = Sheet1.[a65536].End(xlUp).RowFor b = a To 2 Step -1If Cells(b, 1).Value = "删除" ThenRows(b).DeleteEnd IfNextEnd Sub101：删除A列非数字单元行Sub 删除A列非数字单元行()i = [a65536].End(xlUp).RowRange("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End Sub102：有条件删除当前行Sub 有条件删除当前行()If [A1] = 2 Or [B1] = "删除" ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub103：选择下一行Sub 选择下一行()ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.SelectEnd Sub104：选择第5行开始所有数据行Sub 选择第5行开始所有数据行A()Dim i%i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).EntireRow.RowRows("5:" & i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows("5:" & Cells.Find("*", , , , 1, 2).Row).SelectEnd Sub105：选择光标或选区所在行Sub 选择光标或选区所在行()Selection.EntireRow.SelectEnd Sub106：选择光标或选区所在列Sub 选择光标或选区所在列()Selection.EntireColumn.SelectEnd Sub107：光标定位到名称指定位置Sub 定位()Application.Goto Range(Evaluate("名称"))End Sub108：选择名称定义的数据区Sub 选择名称定义的数据区()[数据区].Select '插入名称要使用INDIRECT函数'Range("数据区").Select 或者'Sheet1.Range("数据区").Select 或者End Sub109：选择到指定列的最后行Sub 选择到指定列的最后行()Range("C4:G" & [G65536].End(xlUp).Row).SelectEnd Sub110：将Sheet1的A列的非空值写到Sheet2的A列Sub 将Sheet1的A列的非空值写到Sheet2的A列()Sheet1.Columns("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1] End Sub111：将名称1的数据写到名称2Sub Macro2()Range("位置2") = Range("位置1").ValueEnd Sub112：单元反选Sub 单元反选()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress As String, taddress As Stringraddress = Selection.Addresstaddress = edRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = "=0"raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address.DeleteEnd WithActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub113：调整选中对象中的文字Sub 调整选中对象中的文字()'文字居中：自动调整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd WithEnd Sub114：去除指定围的对象Sub 去除指定围的对象()Dim p As ShapeSet My = Worksheets("工作表名")For Each p In My.ShapesIf Not Application.Intersect(p.TopLeftCell, Range("围")) Is Nothing Then p.DeleteNextEnd Sub115：更新透视表数据项Sub DeleteMissingItems2002All()'防止数据透视表中显示无用的数据项'在 Excel 2002 或更高版本中'假如无用的数据项已经存在,'运行这个宏可以更新Dim pt As PivotTableDim ws As WorksheetFor Each ws In ActiveWorkbook.WorksheetsFor Each pt In ws.PivotTablespt.PivotCache.MissingItemsLimit = xlMissingItemsNoneNext ptNext wsEnd Sub116：将所有工作表名称写到A列Sub 将所有表名称写到A列()k = 1For Each Sht In SheetsCells(k + 1, 1) = '指定写入的行和列k = k + 1NextEnd Sub117：为当前选定的多单元插入指定名称Sub 为当前选定的多单元插入指定名称() = "临时"s.Add Name:="临时", RefersTo:=Selection '或者换用这行代码也可以End Sub118：删除所有名称Sub 删除所有名称()On Error Resume NextDim l As Integerl = s.CountFor i = l To 1 Step -1s(i).DeleteNextEnd Sub119：以指定区域为表目录补充新表Sub 以指定区域为表目录补充新表()Dim dic As Object, sh As WorksheetDim arr, itemarr = Range("B1:BB1")Set dic = CreateObject("scripting.dictionary")For Each sh In ThisWorkbook.Worksheetsdic.Add , ""NextFor Each item In arrIf item <> "" And Not dic.exists(Trim(item)) Then With ThisWorkbook.Worksheets.Add.Name = itemEnd WithEnd IfNextSet dic = NothingEnd Sub120：按A列数据批量修改表名称Sub 按A列数据批量修改表名称()Dim i%For i = 1 To Sheets.Count - 1Sheets(i).Name = Cells(i + 1, 1).TextNextEnd Sub121：按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 Sub122：清除剪贴板Sub 清除剪贴板()Application.CutCopyMode = FalsemandBars("Task Pane").Visible = FalseEnd Sub123：批量清除软回车Sub 批量清除软回车()'也可直接使用Alt+10或13替换Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:= _ xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub124：判断指定文件是否已经打开Sub 判断指定文件是否已经打开()Dim x As IntegerFor x = 1 To Workbooks.CountIf Workbooks(x).Name = "函数.xls" Then '文件名称MsgBox "文件已打开"Exit SubEnd IfNextMsgBox "文件未打开"End Sub125：当前文件另存到指定目录Sub 当前激活文件另存到指定目录()ActiveWorkbook.SaveAs Filename:="E:\信件\" & End Sub126：另存指定文件名Sub 另存指定文件名()ActiveWorkbook.SaveAs ThisWorkbook.Path & "\别名.xls"End Sub127：以本工作表名称另存文件到当前目录Sub 以本工作表名称另存文件到当前目录()ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & & ".xls"End Sub128：将本工作表单独另存文件到Excel当前默认目录Sub 将本工作表单独另存文件到Excel当前默认目录()ActiveSheet.CopyActiveWorkbook.SaveAs Filename:= & ".xls"End Sub129：以活动工作表名称另存文件到Excel当前默认目录Sub 以活动工作表名称另存文件到Excel当前默认目录()ActiveWorkbook.SaveAs Filename:= & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _, CreateBackup:=FalseEnd Sub130：另存所有工作表为工作簿Sub 另存所有工作表为工作簿()Dim sht As WorksheetApplication.ScreenUpdating = Falseipath = ThisWorkbook.Path & "\"For Each sht In Sheetssht.CopyActiveWorkbook.SaveAs ipath & & ".xls" '(工作表名称为文件名）'ActiveWorkbook.SaveAs ipath & & Trim(sht.[d15]) & ".xls" '（文件名称 & D15单元容）'ActiveWorkbook.SaveAs ipath & Trim(sht.[d15]) & ".xls" '（文件名称为D15单元容）ActiveWorkbook.CloseNextApplication.ScreenUpdating = TrueEnd Sub131：以指定单元容为新文件名另存文件Sub 以指定单元容为新文件名另存文件()ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.[A1]End Sub132：以当前日期为新文件名另存文件Sub 以当前日期为新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls" End SubSub 以当前日期为名称另存文件()ActiveWorkbook.SaveAs Filename:=Date & ".xls"End Sub133：以当前日期和时间为新文件名另存文件Sub 以当前日期和时间为新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls"End Sub134：另存本表为TXT文件Sub 另存本表为TXT文件()Dim s As StringDim FullName As String, rng As RangeApplication.ScreenUpdating = FalseFullName = ( & ".txt") '以当前表名为TXT文件名' FullName = Replace(ThisWorkbook.FullName, ".xls", ".txt") '以当前文件名为TXT 文件名' FullName = Replace(ThisWorkbook.FullName, ".xls", & ".txt") '以文件名&表名为TXT文件名Open FullName For Output As #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 Sub135：引用指定位置单元容为部分文件名另存文件Sub 引用指定位置单元容为部分文件名另存文件()ActiveWorkbook.SaveAs Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls"End Sub136：将A列数据排序到D列Sub 将A列数据排序到D列()[d:d] = [a:a].Value[d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYesEnd Sub137：将指定围的数据排列到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 Sub138：光标所在行上移一行Sub 光标所在行上移一行()Dim i%i = Split(ActiveCell.Address, "$")(2)If i > 1 ThenRows(i).CutRows(i - 1).Insert Shift:=xlDownEnd IfEnd Sub139：加数据有效限制Sub 加数据有效限制()With Selection.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="bigsun010sina.".IgnoreBlank = False.InCellDropdown = False.InputTitle = "".ErrorTitle = "".InputMessage = "".ErrorMessage = "要奋斗就会有牺牲，死人的事是经常发生的。
(完整)excel常用宏
1.拆分单元格赋值Sub 拆分填充(）Dim x As RangeFor Each x In ActiveSheet。
UsedRange.CellsIf x。
MergeCells Thenx.Selectx.UnMergeSelection.Value = x。
ValueEnd IfNext xEnd Sub2.E xcel 宏按列拆分多个excelSub Macro1()Dim wb As Workbook， arr， rng As Range, d As Object, k， t, sh As Worksheet, i&Set rng = Range（"A1：f1")Application。
ScreenUpdating = FalseApplication。
DisplayAlerts = Falsearr = Range("a1：a” & Range（"b” & Cells.Rows。
Count）.End（xlUp)。
Row)Set d = CreateObject("scripting。
dictionary"）For i = 2 To UBound(arr）If Not d.Exists(arr（i, 1）） ThenSet d（arr(i, 1）） = Cells(i, 1）。
Resize（1， 13）ElseSet d(arr（i， 1)） = Union(d(arr(i, 1))， Cells（i, 1）.Resize(1， 13)) End IfNextk = d.Keyst = d.ItemsFor i = 0 To d。
Count - 1Set wb = Workbooks。
Add（xlWBATWorksheet)With wb。
Sheets(1)rng。
Copy 。
［A1]t(i）。
Copy 。
超级好用的execl中的259个常用宏
宏文件集▲打开全部隐藏工作表返回Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = TrueNext iEnd Sub▲循环宏返回Sub 循环()AAA = Range("C2")Dim i As LongDim times As Longtimes = AAA'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range("完成标志") = "完成" Then Exit For '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则只执行一次循环就退出'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For '如果某列出现"完成"内容则退出循环Next iEnd Sub▲录制宏时调用“停止录制”工具栏返回Sub 录制宏时调用停止录制工具栏()mandBars("Stop Recording").Visible = TrueEnd Sub▲高级筛选5列不重复数据至指定表返回Sub 高级筛选5列不重复数据至Sheet2()Sheets("Sheet2").Range("A1:E65536") = "" '清除Sheet2的A:D列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _"A1"), Unique:=TrueSheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"), Order1:=xlAscending,Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub▲双击单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$4"Call 宏1Cancel = TrueCase "$B$4"Call 宏2Cancel = TrueCase "$C$4"Call 宏3Cancel = TrueCase "$E$4"Call 宏4Cancel = TrueEnd SelectEnd Sub▲双击指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then Call 打开隐藏表End Sub▲进入单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)'以单元格进入代替按钮对象调用宏If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$5" '单元地址(Target.Address),或命名单元名字()Call 宏1Case "$B$5"Call 宏2Case "$C$5"Call 宏3End SelectEnd Sub▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call打开隐藏表End Sub▲在多个宏中依次循环执行一个（控件按钮代码）返回Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub▲在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()With CommandButton1If .Caption = "保护工作表" ThenCall 保护工作表.Caption = "取消工作表保护"Exit SubEnd IfIf .Caption = "取消工作表保护" ThenCall 取消工作表保护.Caption = "保护工作表"Exit SubEnd IfEnd WithEnd Sub▲在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = "宏1" ThenCall 宏1.Caption = "宏2"Exit SubEnd IfIf .Caption = "宏2" ThenCall 宏2.Caption = "宏3"Exit SubEnd IfIf .Caption = "宏3" ThenCall 宏3.Caption = "宏1"Exit SubEnd IfEnd WithEnd Sub▲根据A1单元文本隐藏/显示按钮（控件按钮代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("A1") > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub▲当前单元返回按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub▲当前单元内容返回到按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub▲奇偶页分别打印返回Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数MsgBox "现在打印奇数页,按确定开始."For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox "现在打印偶数页,按确定开始."For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub▲自动打印多工作表第一页返回Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx = InputBox("请输入起始工作表名字:")sy = InputBox("请输入结束工作表名字:")y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub▲查找A列文本循环插入分页符返回Sub 循环插入分页符()' Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页")'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub▲将A列最后数据行以上的所有B列图片大小调整为所在单元大小返回Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing ThenPic.Top = Pic.TopLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub▲返回光标所在行数返回Sub 返回光标所在行数()x = ActiveCell.RowRange("A1") = xEnd Sub▲在A1返回当前选中单元格数量返回Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub▲返回当前工作簿中工作表数量返回Sub 返回当前工作簿中工作表数量()t = Application.Sheets.CountMsgBox tEnd Sub▲返回光标选择区域的行数和列数返回Sub 返回光标选择区域的行数和列数()x = Selection.Rows.County = Selection.Columns.CountRange("A1") = xRange("A2") = yEnd Sub▲工作表中包含数据的最大行数返回Sub 包含数据的最大行数()n = Cells.Find("*", , , , 1, 2).RowMsgBox nEnd Sub▲返回A列数据的最大行数返回Sub 返回A列数据的最大行数()n = Range("a65536").End(xlUp).RowRange("B1") = nEnd Sub▲将所选区域文本插入新建文本框返回Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left +ActiveCell.Width, ActiveCell.Top + ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = "问题：" & nWith Selection.Characters(Start:=1, Length:=3).Font.Name = "黑体".FontStyle = "常规".Size = 12End WithEnd Sub▲批量插入地址批注返回Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionment.Deleter.AddCommentment.Visible = Falsement.Text Text:="本单元格：" & r.Address & " of " & Selection.AddressNextEnd IfEnd Sub▲批量插入统一批注返回Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=msgNextEnd IfEnd Sub▲以A1单元内容批量插入批注返回Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=[a1].TextNextEnd IfEnd Sub▲不连续区域插入当前文件名和表名及地址返回Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = "[" + + "]" + +"!" + mycell.AddressNextEnd Sub▲不连续区域录入当前单元地址返回Sub 区域录入当前单元地址()For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub▲连续区域录入当前单元地址返回Sub 连续区域录入当前单元地址()Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub▲返回当前单元地址返回Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub▲不连续区域录入当前日期返回Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")End Sub▲不连续区域录入当前数字日期返回Sub 区域录入当前数字日期()Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")End Sub▲不连续区域录入当前日期和时间返回Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")End Sub▲不连续区域录入对勾返回Sub 批量录入对勾()Selection.FormulaR1C1 = "√"End Sub▲不连续区域录入当前文件名返回Sub 批量录入当前文件名()Selection.FormulaR1C1 = End Sub▲不连续区域添加文本返回Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & "文本内容"NextEnd Sub▲不连续区域插入文本返回Sub 批量插入文本()Dim s As RangeFor Each s In Selections = "文本内容" & sNextEnd Sub▲从指定位置向下同时录入多单元指定内容返回Sub 从指定位置向下同时录入多单元指定内容()Dim arrarr = Array("1", "2", "13", "25", "46", "12", "0", "20")[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub▲按aa工作表A列的内容排列工作表标签顺序返回Sub 按aa工作表A列的内容排列工作表标签顺序()Dim I%, str1$I = 1Sheets("aa").SelectDo While Cells(I, 1).Value <> ""str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets("aa").SelectLoopEnd Sub▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add = nmEnd Sub▲删除全部未选定工作表返回Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As BooleanDim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n - 1If ShtName(i) = TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub▲工作表标签排序返回Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox("工作表按升序排列请选 '是[Y]'. " & vbCrLf & vbCrLf & "工作表按降序排列请选 '否[N]'", vbYesNoCancel, "工作表排序")If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then 'Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse 'Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub▲定义指定工作表标签颜色返回Sub 定义指定工作表标签颜色()Sheets("Sheet1").Tab.ColorIndex = 46End Sub▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets("目录").ActivateIf Err = 0 ThenSheets("目录").UsedRange.DeleteElseSheets.Add = "目录"End IfFor i = 1 To Sheets.CountIf Sheets(i).Name <> "目录" Thens = s + 1Set Rng = Sheets("目录").Cells(((s - 1) Mod 20) + 1, (s - 1) \ 20 + 1 + 1)Rng = Format(s, " 0") & ". " & Sheets(i).NameActiveSheet.Hyperlinks.Add Rng, "#" & Sheets(i).Name & "!A1",ScreenTip:=Sheets(i).NameEnd IfNextSheets("目录").Range("b:iv").EntireColumn.ColumnWidth = 20End Sub▲建立工作表文本目录返回Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)Sheets(1).Name = "目录"For i = 2 To Sheets.CountCells(i - 1, 1) = Sheets(i).Name'Sheets(1).Hyperlinks.Add Cells(i - 1, 1), "#" & Sheets(i).Name & "!A1" '添加超链接NextEnd Sub▲查另一文件的全部表名返回Sub 查另一文件的全部表名()On Error Resume NextDim i%Dim sh As WorksheetApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=ThisWorkbook.Path & "\2.xls"Windows("1.xls").Activate '当前文件名称Sheets("Sheet1").Select '当前表名称i = 1 '将表名称返回到第1行For Each sh In Workbooks("2.xls").WorksheetsCells(i, 1) = '将表名称返回到第1列i = i + 1 '返回每个表名称向下移动1行Next shWindows("2.xls").Close '关闭对象文件Application.ScreenUpdating = TrueEnd Sub▲当前单元录入计算机名返回Sub 当前单元录入计算机名()Selection = Environ("COMPUTERNAME")'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲当前单元录入计算机用户名返回 Sub 当前单元录入计算机用户名()Selection = Environ("Username")'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲解除全部工作表保护返回Sub 解除全部工作表保护()Dim n As IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext nEnd Sub▲为指定工作表加指定密码保护表返回Sub 为指定工作表加指定密码保护表()Sheet10.Protect Password:="123"End Sub▲在有密码的工作表执行代码返回Sub 在有密码的工作表执行代码()Sheets("1").Unprotect Password:=123 '假定表名为“1”，密码为“123” 打开工作表Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True '隐藏C列空值行Sheets("1").Protect Password:=123 '重新用密码保护工作表End Sub▲执行前需要验证密码的宏(控件按钮代码)返回Private Sub CommandButton1_Click()If InputBox("请输入密码：") <> "123" Then '密码是123MsgBox "密码错误,按确定退出!", 64, "提示"Exit SubEnd IfCells(1, 1) = 10End SubSub 执行前需要验证密码的宏()If InputBox("请输入您的使用权限:", "系统提示") = 123 Then重排窗口 '要执行的宏代码或宏名称ElseMsgBox "对不起,您没有使用该宏的权限,按确定键后退出!"End IfEnd Sub▲拷贝A1公式和格式到A2返回Sub 拷贝A1公式到A2()Workbooks("临时表").Sheets("表1").Range("A1").CopyWorkbooks("临时表").Sheets("表2").Range("A2").PasteSpecialEnd Sub▲复制单元数值返回Sub 复制数值()s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2")Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = sEnd Sub▲插入数值条件格式返回Sub 插入数值条件格式()Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="70"Selection.FormatConditions(1).Interior.ColorIndex = 45Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _Formula1:="55"Selection.FormatConditions(2).Interior.ColorIndex = 39Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="60"Selection.FormatConditions(3).Interior.ColorIndex = 34End Sub▲插入透明批注返回Sub 插入透明批注()Selection.AddCommentment.Visible = FalseDim XS As WorksheetFor i = 1 To ments.Countments(i).Text "透明批注"ments(i).Shape.Fill.Visible = msoFalseNextEnd Sub▲添加文本返回Sub 添加文本()Selection = Selection + "×" '不可在数字后添加文本'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲光标定位到指定工作表A列最后数据行下一单元返回Sub 光标定位到指定工作表A列最后数据行下一单元()a = Sheets("数据库").[a65536].End(xlUp).RowSheets("数据库").SelectRange("A" & a + 1).SelectEnd Sub▲定位选定单元格式相同的全部单元格返回Sub 定位选定单元格式相同的全部单元格()Dim FirstCell As Range, FoundCell As RangeDim AllCells As RangeWith Application.FindFormat.Clear.NumberFormatLocal = Selection.NumberFormatLocal.HorizontalAlignment = Selection.HorizontalAlignment.VerticalAlignment = Selection.VerticalAlignment.WrapText = Selection.WrapText.Orientation = Selection.Orientation.AddIndent = Selection.AddIndent.IndentLevel = Selection.IndentLevel.ShrinkToFit = Selection.ShrinkToFit.MergeCells = Selection.MergeCells = .Font.FontStyle = Selection.Font.FontStyle.Font.Size = Selection.Font.Size.Font.Strikethrough = Selection.Font.Strikethrough.Font.Subscript = Selection.Font.Subscript.Font.Underline = Selection.Font.Underline.Font.ColorIndex = Selection.Font.ColorIndex.Interior.ColorIndex = Selection.Interior.ColorIndex.Interior.Pattern = Selection.Interior.Pattern.Locked = Selection.Locked.FormulaHidden = Selection.FormulaHiddenEnd WithSet FirstCell = edRange.Find(what:="", searchformat:=True)If FirstCell Is Nothing ThenExit SubEnd IfSet AllCells = FirstCellSet FoundCell = FirstCellDoSet FoundCell = edRange.Find(After:=FoundCell, what:="",searchformat:=True)If FoundCell Is Nothing Then Exit DoSet AllCells = Union(FoundCell, AllCells)If FoundCell.Address = FirstCell.Address Then Exit DoLoopAllCells.SelectEnd Sub▲按当前单元文本定位返回Sub 按当前单元文本定位()ABC = SelectionDim aa As RangeFor Each a In edRangeIf a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲按固定文本定位返回Sub 文本定位()Dim aa As RangeFor Each a In edRangeIf a Like "*合计*" ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲删除包含固定文本单元的行或列返回Sub 删除包含固定文本单元的行或列()DoCells.Find(what:="哈哈").ActivateSelection.EntireRow.Delete '删除行' Selection.EntireColumn.Delete '删除列Loop Until Cells.Find(what:="哈哈") Is NothingEnd Sub▲定位数据及区域以上的空值返回Sub 定位数据及区域以上的空值()Dim aa As RangeFor Each a In edRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲右侧单元自动加5(工作表代码)返回Private Sub Worksheet_Change(ByVal Target As Range)Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd Sub▲当前单元加2返回Sub 当前单元加2()Selection = Selection + 2'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲A列等于A列减B列返回Sub A列等于A列减B列()For i = 1 To 23Cells(i, 1) = Cells(i, 1) - Cells(i, 2)NextEnd Sub▲用于光标选定多区域跳转指定单元(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal T As Range)a = Array([b6:b7], [e6], [h6])For i = 0 To 2If Not Application.Intersect(T, a(i)) Is Nothing Then[a1].Select: Exit ForEnd IfNextEnd Sub▲将A1单元录入的数据累加到B1单元（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)Dim t As LongIf Target.Address = "$A$1" Thent = Sheet1.Range("$B$1").ValueSheet1.Range("$B$1").Value = t + Target.ValueEnd IfEnd Sub▲在指定颜色区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> "√", "√", "")NextEnd Sub▲在指定区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target, Range("D6:D20")) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = "" Then.Value = "√"Else.Value = ""End IfEnd WithNextEnd IfEnd IfEnd Sub▲双击指定单元，循环录入文本（工作表代码）返回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双击指定单元，循环录入文本（工作表代码）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▲单元区域引用（工作表代码）返回Private Sub Worksheet_Activate()Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").ValueEnd Sub▲在指定区域选择单元时数值加1（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect([a1:e10], Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub▲混合文本的编号返回Sub 混合文本的编号()Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3,100)) + 1)End Sub▲指定区域单元双击数据累加（工作表代码）返回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▲选择单元区域触发事件（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = "$A$1:$B$2" ThenMsgBox "你选择了$A$1:$B$2单元"End IfEnd Sub▲当修改指定单元内容时自动执行宏（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then重排窗口End IfEnd Sub▲被指定单元内容限制执行宏返回Sub 被指定单元限制执行宏()If Range("$A$1") = "关闭" Then Exit Sub窗口End Sub▲双击单元隐藏该行（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Rows(Target.Row).Hidden = TrueEnd Sub▲高亮显示行（工作表代码）返回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▲高亮显示行和列（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34Columns(Target.Column).Interior.ColorIndex = 34End Sub▲为指定工作表设置滚动范围（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)Sheet1.ScrollArea = "A1:M30"End Sub▲在指定单元记录打印和预览次数（工作簿代码）返回Private Sub Workbook_BeforePrint(Cancel As Boolean)Range("A1") = 1 + Range("A1")End Sub▲自动数字金额转大写（工作表代码）返回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 * 100f = (j / 10 - Int(j / 10)) * 10A = 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▲将全部工作表的A1单元作为单击按钮（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)If Target.Address = "$A$1" ThenCall 宏名End IfEnd Sub▲闹钟——到指定时间执行宏（工作簿代码）返回Private Sub Workbook_Open()Application.OnTime ("11:45:00"), "提示1" '宏名字Application.OnTime ("12:00:00"), "提示2" '宏名字End Sub▲改变Excel界面标题的宏（工作簿代码）返回Private Sub Workbook_Open()Application.Caption = "春节快乐"End Sub▲在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)Worksheets("表2").Range("A1") = Target.Address(0, 0)End Sub▲B列录入数据时在A列返回记录时间（工作表代码）返回Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub▲当指定区域修改时在其右侧的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▲指定单元显示光标位置内容（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal T As Range)Sheets(1).Range("A1") = SelectionEnd Sub▲每编辑一个单元保存文件返回Private Sub Worksheet_Change(ByVal Target As Range)ThisWorkbook.SaveEnd Sub▲指定允许编辑区域返回Sub 指定允许编辑区域()ActiveSheet.ScrollArea = "B8:G15"End Sub▲解除允许编辑区域限制返回Sub 解除允许编辑区域限制()ActiveSheet.ScrollArea = ""End Sub▲删除指定行返回Sub 删除指定行()Workbooks("临时表").Sheets("表2").Range("5:5").DeleteEnd Sub▲删除A列为指定内容的行返回Sub 删除A列为指定内容的行()Dim a, b As Integera = Sheet1.[a65536].End(xlUp).RowFor b = a To 2 Step -1If Cells(b, 1).Value = "删除" ThenRows(b).DeleteEnd IfNextEnd Sub▲删除A列非数字单元行返回Sub 删除A列非数字单元行()i = [a65536].End(xlUp).RowRange("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.DeleteEnd Sub▲有条件删除当前行返回Sub 有条件删除当前行()If [A1] = 2 Or [B1] = "删除" ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub▲选择下一行返回Sub 选择下一行()ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.SelectEnd Sub▲选择第5行开始所有数据行返回Sub 选择第5行开始所有数据行A()Dim i%i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues,SearchDirection:=xlPrevious).EntireRow.RowRows("5:" & i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows("5:" & Cells.Find("*", , , , 1, 2).Row).SelectEnd Sub▲选择光标或选区所在行返回Sub 选择光标或选区所在行()Selection.EntireRow.Select▲选择光标或选区所在列返回Sub 选择光标或选区所在列()Selection.EntireColumn.SelectEnd Sub▲光标定位到名称指定位置返回Sub 定位()Application.Goto Range(Evaluate("名称"))End Sub▲选择名称定义的数据区返回Sub 选择名称定义的数据区()[数据区].Select '插入名称要使用INDIRECT函数'Range("数据区").Select 或者'Sheet1.Range("数据区").Select 或者End Sub▲选择到指定列的最后行返回Sub 选择到指定列的最后行()Range("C4:G" & [G65536].End(xlUp).Row).SelectEnd Sub▲将Sheet1的A列的非空值写到Sheet2的A列返回Sub 将Sheet1的A列的非空值写到Sheet2的A列()Sheet1.Columns("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1]End Sub▲将名称1的数据写到名称2返回Sub Macro2()Range("位置2") = Range("位置1").Value▲单元反选返回Sub 单元反选()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress As String, taddress As Stringraddress = Selection.Addresstaddress = edRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = "=0"raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address.DeleteEnd WithActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub▲调整选中对象中的文字返回Sub 调整选中对象中的文字()'文字居中、自动调整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd WithEnd Sub▲去除指定范围内的对象返回Sub 去除指定范围内的对象()。
excel常用宏集合
65：删除包含固定文本单元的行或列Sub 删除包含固定文本单元的行或列()Do(what:="哈哈").Activate'删除行' '删除列Loop Until (what:="哈哈") Is NothingEnd Sub72：在指定颜色区域选择单元时添加/取消"√"（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf = 37 Then myrg = IIf(myrg <> "√", "√", "")NextEnd Sub73：在指定区域选择单元时添加/取消"√"（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf <= 15 ThenIf Not (Target, Range("D6:D20")) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = "" Then.Value = "√"Else.Value = ""End IfEnd WithNextEnd IfEnd IfEnd Sub74：双击指定单元，循环录入文本（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)If <> "$A$1" Then Exit SubCancel = TrueT = IIf(T = "好", "中", IIf(T = "中", "差", "好"))End Sub75：双击指定单元，循环录入文本（工作表代码）Dim nums As BytePrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If = "$A$1" Thennums = nums Mod 3 + 1Target = Mid("上中下", nums, 1)(1, 0).SelectEnd IfEnd Sub76：单元区域引用（工作表代码）Private Sub Worksheet_Activate()("A1:B3").Value = ("A1:B3").ValueEnd Sub77：在指定区域选择单元时数值加1（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not ([a1:e10], Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub259个常用宏-excelhome(3)2009-08-15 14:12:5878：混合文本的编号Sub 混合文本的编号()Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3, 100)) + 1)79：指定区域单元双击数据累加（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not ([A1:Y100], Target) Is Nothing Thenoldvalue = Valinputvalue = InputBox("请输入数量,按ENTER键确认!", "数值累加器")= oldvalue + inputvalueEnd IfEnd Sub80：选择单元区域触发事件（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If = "$A$1:$B$2" ThenMsgBox "你选择了$A$1:$B$2单元"End IfEnd Sub81：当修改指定单元内容时自动执行宏（工作表代码）Private Sub Worksheet_Change(ByVal Target As Range)If Not (Target, [B3:B4]) Is Nothing Then重排窗口End IfEnd Sub82：被指定单元内容限制执行宏Sub 被指定单元限制执行宏()If Range("$A$1") = "关闭" Then Exit Sub窗口End Sub83：双击单元隐藏该行（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Rows.Hidden = True84：高亮显示行（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)= 2Rows("1:2"). = 40 '保持1至2行的颜色推荐39,22,40,Rows. = 35 '高亮推荐颜色35,20,24,34,37,40,15End Sub85：高亮显示行和列（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)= xlNoneRows. = 34Columns. = 34End Sub86：为指定工作表设置滚动范围（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)= "A1:M30"End Sub87：在指定单元记录打印和预览次数（工作簿代码）Private Sub Workbook_BeforePrint(Cancel As Boolean)Range("A1") = 1 + Range("A1")End Sub88：自动数字金额转大写（工作表代码）Private Sub Worksheet_Change(ByVal M As Range)On Error Resume Nexty = Int(Round(100 * Abs(M)) / 100)j = Round(100 * Abs(M) + - y * 100f = (j / 10 - Int(j / 10)) * 10A = IIf(y < 1, "", (y, "[DBNum2]") & "元")b = IIf(j > , (Int(j / 10), "[DBNum2]") & "角", IIf(y < 1, "", IIf(f > 1, "零", "")))c = IIf(f < 1, "整", (Round(f, 0), "[DBNum2]") & "分")M = IIf(Abs(M) < , "", IIf(M < 0, "负" & A & b & c, A & b & c))End Sub89：将所有工作表的A1单元作为单击按钮（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)If = "$A$1" ThenCall 宏名End IfEnd Sub90：闹钟——到指定时间执行宏（工作簿代码）Private Sub Workbook_Open()("11:45:00"), "提示1" '宏名字("12:00:00"), "提示2" '宏名字End Sub91：改变Excel界面标题的宏（工作簿代码）Private Sub Workbook_Open()= "春节快乐"End Sub92：在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Worksheets("表2").Range("A1") = (0, 0)End Sub93：B列录入数据时在A列返回记录时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range)If = 2 Then(, -1) = NowEnd IfEnd Sub94：当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range)If Not (Target, [A1:A1000]) Is Nothing ThenIf = 1 Then(, 1) = Date(, 2) = TimeEnd IfEnd IfEnd SubPublic Sub Worksheet_Change(ByVal Target As Range)If Not (Target, [A1:A1000]) Is Nothing ThenIf = 1 Then(, 1) = Format(Now(), "yyyy-mm-dd")(, 2) = Format(Now(), "h:mm:ss")End IfEnd IfEnd Sub95：指定单元显示光标位置内容（工作表代码）Private Sub Worksheet_SelectionChange(ByVal T As Range)Sheets(1).Range("A1") = SelectionEnd Sub96：每编辑一个单元保存文件Private Sub Worksheet_Change(ByVal Target As Range)End Sub97：指定允许编辑区域Sub 指定允许编辑区域()= "B8:G15"98：解除允许编辑区域限制Sub 解除允许编辑区域限制()= ""End Sub99：删除指定行Sub 删除指定行()Workbooks("临时表").Sheets("表2").Range("5:5").Delete End Sub100：删除A列为指定内容的行Sub 删除A列为指定内容的行()Dim a, b As Integera = Sheet1.[a65536].End(xlUp).RowFor b = a To 2 Step -1If Cells(b, 1).Value = "删除" ThenRows(b).DeleteEnd IfNextEnd Sub101：删除A列非数字单元行Sub 删除A列非数字单元行()i = [a65536].End(xlUp).RowRange("A1:A" & i).SpecialCells(xlCellTypeConstants, 2). End Sub102：有条件删除当前行Sub 有条件删除当前行()If [A1] = 2 Or [B1] = "删除" ThenShift:=xlUpEnd If103：选择下一行Sub 选择下一行()(1, 0).Rows("1:1").End Sub104：选择第5行开始所有数据行Sub 选择第5行开始所有数据行A()Dim i%i = ("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Rows("5:" & i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows("5:" & ("*", , , , 1, 2).Row).SelectEnd Sub105：选择光标或选区所在行Sub 选择光标或选区所在行()Sub106：选择光标或选区所在列Sub 选择光标或选区所在列()Sub107：光标定位到名称指定位置Sub 定位()Range(Evaluate("名称"))End Sub108：选择名称定义的数据区Sub 选择名称定义的数据区()[数据区].Select '插入名称要使用INDIRECT函数'Range("数据区").Select 或者'("数据区").Select 或者End Sub109：选择到指定列的最后行Sub 选择到指定列的最后行()Range("C4:G" & [G65536].End(xlUp).Row).SelectEnd Sub110：将Sheet1的A列的非空值写到Sheet2的A列Sub 将Sheet1的A列的非空值写到Sheet2的A列()("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1]End Sub111：将名称1的数据写到名称2Sub Macro2()Range("位置2") = Range("位置1").ValueEnd Sub112：单元反选Sub 单元反选()= False= FalseDim raddress As String, taddress As Stringraddress =taddress =.Range(taddress) = 0.Range(raddress) = "=0"raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address .DeleteEnd With(raddress).Select= TrueEnd Sub113：调整选中对象中的文字Sub 调整选中对象中的文字()'文字居中：自动调整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd WithEnd Sub114：去除指定范围内的对象Sub 去除指定范围内的对象()Dim p As ShapeSet My = Worksheets("工作表名")For Each p InIf Not , Range("范围")) Is Nothing Then NextEnd Sub115：更新透视表数据项Sub DeleteMissingItems2002All()'防止数据透视表中显示无用的数据项'在 Excel 2002 或更高版本中'假如无用的数据项已经存在,'运行这个宏可以更新Dim pt As PivotTableDim ws As WorksheetFor Each ws InFor Each pt In= xlMissingItemsNoneNext ptNext wsEnd Sub116：将所有工作表名称写到A列Sub 将所有表名称写到A列()k = 1For Each Sht In SheetsCells(k + 1, 1) = '指定写入的行和列k = k + 1NextEnd Sub117：为当前选定的多单元插入指定名称Sub 为当前选定的多单元插入指定名称()= "临时"Name:="临时", RefersTo:=Selection '或者换用这行代码也可以End Sub118：删除所有名称Sub 删除所有名称()On Error Resume NextDim l As Integerl = i = l To 1 Step -1(i).DeleteNextEnd Sub119：以指定区域为表目录补充新表Sub 以指定区域为表目录补充新表()Dim dic As Object, sh As WorksheetDim arr, itemarr = Range("B1:BB1")Set dic = CreateObject("")For Each sh In, ""NextFor Each item In arrIf item <> "" And Not (Trim(item)) ThenWith .Name = item End WithEnd IfNextSet dic = NothingEnd Sub120：按A列数据批量修改表名称Sub 按A列数据批量修改表名称()Dim i%For i = 1 To - 1Sheets(i).Name = Cells(i + 1, 1).Text NextEnd Sub121：按A列数据批量创建新表(控件按钮代码)Private Sub CommandButton1_Click()On Error Resume NextDim i%, j%For i = 1 To [a65536].End(xlUp).RowFor j = 2 ToIf Cells(i, 1) = Sheets(j).Name ThenExit ForEnd IfNext(after:=Sheets).Name = Cells(i, 1)NextEnd Sub122：清除剪贴板Sub 清除剪贴板()= False("Task Pane").Visible = FalseEnd Sub123：批量清除软回车Sub 批量清除软回车()'也可直接使用Alt+10或13替换What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:= _xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub124：判断指定文件是否已经打开Sub 判断指定文件是否已经打开()Dim x As IntegerFor x = 1 ToIf Workbooks(x).Name = "函数.xls" Then '文件名称MsgBox "文件已打开"Exit SubEnd IfNextMsgBox "文件未打开"End Sub125：当前文件另存到指定目录Sub 当前激活文件另存到指定目录()Filename:="E:\信件\" &End Sub126：另存指定文件名Sub 另存指定文件名()& "\别名.xls"End Sub127：以本工作表名称另存文件到当前目录Sub 以本工作表名称另存文件到当前目录()Filename:= & "\" & & ".xls"End Sub128：将本工作表单独另存文件到Excel当前默认目录Sub 将本工作表单独另存文件到Excel当前默认目录()Filename:= & ".xls"End Sub129：以活动工作表名称另存文件到Excel当前默认目录Sub 以活动工作表名称另存文件到Excel当前默认目录()Filename:= & ".xls", FileFormat:= _xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _, CreateBackup:=FalseEnd Sub130：另存所有工作表为工作簿Sub 另存所有工作表为工作簿()Dim sht As Worksheet= Falseipath = & "\"For Each sht In Sheetsipath & & ".xls" '(工作表名称为文件名）' ipath & & Trim(sht.[d15]) & ".xls" '（文件名称 & D15单元内容）' ipath & Trim(sht.[d15]) & ".xls" '（文件名称为D15单元内容）Next= TrueEnd Sub131：以指定单元内容为新文件名另存文件Sub 以指定单元内容为新文件名另存文件()Filename:= & "\" & Sheet1.[A1]End Sub132：以当前日期为新文件名另存文件Sub 以当前日期为新文件名另存文件()& "\" & Format(Now(), "yyyymmdd") & ".xls"End SubSub 以当前日期为名称另存文件()Filename:=Date & ".xls"End Sub133：以当前日期和时间为新文件名另存文件Sub 以当前日期和时间为新文件名另存文件()& "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls"End Sub134：另存本表为TXT文件Sub 另存本表为TXT文件()Dim s As StringDim FullName As String, rng As Range= FalseFullName = & ".txt") '以当前表名为TXT文件名' FullName = Replace, ".xls", ".txt") '以当前文件名为TXT文件名' FullName = Replace, ".xls", & ".txt") '以文件名&表名为TXT文件名Open FullName For Output As #1 '以读写方式打开文件，每次写内容都会覆盖原先的内容'参考帮助，fullname为文件全名For Each rng In Range("a1").CurrentRegions = s & IIf(s = "", "", "|") &If = Range("a1"). ThenPrint #1, s & "|" '把数据写到文本文件里s = ""End IfNextClose #1 '关闭文件= TrueMsgBox "数据已导入文本"End Sub135：引用指定位置单元内容为部分文件名另存文件Sub 引用指定位置单元内容为部分文件名另存文件()Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls"End Sub136：将A列数据排序到D列Sub 将A列数据排序到D列()[d:d] = [a:a].Value[d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes End Sub137：将指定范围的数据排列到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 (arr1)i = i + 1arr2(i, 1) = xNext xRange("D1").Resize(i, 1) = arr2End Sub光标移动Sub 光标移动()(1, 2).Select '向下移动1行，向右移动2列End Sub138：光标所在行上移一行Sub 光标所在行上移一行()Dim i%i = Split, "$")(2)If i > 1 ThenRows(i).CutRows(i - 1).Insert Shift:=xlDownEnd IfEnd Sub139：加数据有效限制Sub 加数据有效限制()With.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="".IgnoreBlank = False.InCellDropdown = False.InputTitle = "".ErrorTitle = "".InputMessage = "".ErrorMessage = "要奋斗就会有牺牲，死人的事是经常发生的。
Excel-vba宏代码-大全
宏文件集▲打开全部隐藏工作表返回Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = TrueNext iEnd Sub▲循环宏返回Sub 循环()AAA = Range("C2")Dim i As LongDim times As Longtimes = AAA'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range("完成标志") = "完成" Then Exit For '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则只执行一次循环就退出'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For '如果某列出现"完成"内容则退出循环Next iEnd Sub▲录制宏时调用“停止录制”工具栏返回Sub 录制宏时调用停止录制工具栏()mandBars("Stop Recording").Visible = TrueEnd Sub▲高级筛选5列不重复数据至指定表返回Sub 高级筛选5列不重复数据至Sheet2()Sheets("Sheet2").Range("A1:E65536") = "" '清除Sheet2的A:D列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _"A1"), Unique:=TrueSheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"), Order1:=xlAscending,Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub▲双击单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$4"Call 宏1Cancel = TrueCase "$B$4"Call 宏2Cancel = TrueCase "$C$4"Call 宏3Cancel = TrueCase "$E$4"Call 宏4Cancel = TrueEnd SelectEnd Sub▲双击指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then Call 打开隐藏表End Sub▲进入单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)'以单元格进入代替按钮对象调用宏If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$5" '单元地址(Target.Address),或命名单元名字()Call 宏1Case "$B$5"Call 宏2Case "$C$5"Call 宏3End SelectEnd Sub▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call打开隐藏表End Sub▲在多个宏中依次循环执行一个（控件按钮代码）返回Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub▲在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()With CommandButton1If .Caption = "保护工作表" ThenCall 保护工作表.Caption = "取消工作表保护"Exit SubEnd IfIf .Caption = "取消工作表保护" ThenCall 取消工作表保护.Caption = "保护工作表"Exit SubEnd IfEnd WithEnd Sub▲在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = "宏1" ThenCall 宏1.Caption = "宏2"Exit SubEnd IfIf .Caption = "宏2" ThenCall 宏2.Caption = "宏3"Exit SubEnd IfIf .Caption = "宏3" ThenCall 宏3.Caption = "宏1"Exit SubEnd IfEnd WithEnd Sub▲根据A1单元文本隐藏/显示按钮（控件按钮代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("A1") > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub▲当前单元返回按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub▲当前单元内容返回到按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub▲奇偶页分别打印返回Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数MsgBox "现在打印奇数页,按确定开始."For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox "现在打印偶数页,按确定开始."For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub▲自动打印多工作表第一页返回Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx = InputBox("请输入起始工作表名字:")sy = InputBox("请输入结束工作表名字:")y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub▲查找A列文本循环插入分页符返回Sub 循环插入分页符()' Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页")'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub▲将A列最后数据行以上的所有B列图片大小调整为所在单元大小返回Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing ThenPic.Top = Pic.TopLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub▲返回光标所在行数返回Sub 返回光标所在行数()x = ActiveCell.RowRange("A1") = xEnd Sub▲在A1返回当前选中单元格数量返回Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub▲返回当前工作簿中工作表数量返回Sub 返回当前工作簿中工作表数量()t = Application.Sheets.CountMsgBox tEnd Sub▲返回光标选择区域的行数和列数返回Sub 返回光标选择区域的行数和列数()x = Selection.Rows.County = Selection.Columns.CountRange("A1") = xRange("A2") = yEnd Sub▲工作表中包含数据的最大行数返回Sub 包含数据的最大行数()n = Cells.Find("*", , , , 1, 2).RowMsgBox nEnd Sub▲返回A列数据的最大行数返回Sub 返回A列数据的最大行数()n = Range("a65536").End(xlUp).RowRange("B1") = nEnd Sub▲将所选区域文本插入新建文本框返回Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left +ActiveCell.Width, ActiveCell.Top + ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = "问题：" & nWith Selection.Characters(Start:=1, Length:=3).Font.Name = "黑体".FontStyle = "常规".Size = 12End WithEnd Sub▲批量插入地址批注返回Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionment.Deleter.AddCommentment.Visible = Falsement.Text Text:="本单元格：" & r.Address & " of " & Selection.AddressNextEnd IfEnd Sub▲批量插入统一批注返回Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=msgNextEnd IfEnd Sub▲以A1单元内容批量插入批注返回Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=[a1].TextNextEnd IfEnd Sub▲不连续区域插入当前文件名和表名及地址返回Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = "[" + + "]" + +"!" + mycell.AddressNextEnd Sub▲不连续区域录入当前单元地址返回Sub 区域录入当前单元地址()For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub▲连续区域录入当前单元地址返回Sub 连续区域录入当前单元地址()Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub▲返回当前单元地址返回Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub▲不连续区域录入当前日期返回Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")End Sub▲不连续区域录入当前数字日期返回Sub 区域录入当前数字日期()Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")End Sub▲不连续区域录入当前日期和时间返回Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")End Sub▲不连续区域录入对勾返回Sub 批量录入对勾()Selection.FormulaR1C1 = "√"End Sub▲不连续区域录入当前文件名返回Sub 批量录入当前文件名()Selection.FormulaR1C1 = End Sub▲不连续区域添加文本返回Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & "文本内容"NextEnd Sub▲不连续区域插入文本返回Sub 批量插入文本()Dim s As RangeFor Each s In Selections = "文本内容" & sNextEnd Sub▲从指定位置向下同时录入多单元指定内容返回Sub 从指定位置向下同时录入多单元指定内容()Dim arrarr = Array("1", "2", "13", "25", "46", "12", "0", "20")[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub▲按aa工作表A列的内容排列工作表标签顺序返回Sub 按aa工作表A列的内容排列工作表标签顺序()Dim I%, str1$I = 1Sheets("aa").SelectDo While Cells(I, 1).Value <> ""str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets("aa").SelectLoopEnd Sub▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add = nmEnd Sub▲删除全部未选定工作表返回Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As BooleanDim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n - 1If ShtName(i) = TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub▲工作表标签排序返回Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox("工作表按升序排列请选 '是[Y]'. " & vbCrLf & vbCrLf & "工作表按降序排列请选 '否[N]'", vbYesNoCancel, "工作表排序")If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then 'Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse 'Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub▲定义指定工作表标签颜色返回Sub 定义指定工作表标签颜色()Sheets("Sheet1").Tab.ColorIndex = 46End Sub▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets("目录").ActivateIf Err = 0 ThenSheets("目录").UsedRange.DeleteElseSheets.Add = "目录"End IfFor i = 1 To Sheets.CountIf Sheets(i).Name <> "目录" Thens = s + 1Set Rng = Sheets("目录").Cells(((s - 1) Mod 20) + 1, (s - 1) \ 20 + 1 + 1)Rng = Format(s, " 0") & ". " & Sheets(i).NameActiveSheet.Hyperlinks.Add Rng, "#" & Sheets(i).Name & "!A1",ScreenTip:=Sheets(i).NameEnd IfNextSheets("目录").Range("b:iv").EntireColumn.ColumnWidth = 20End Sub▲建立工作表文本目录返回Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)Sheets(1).Name = "目录"For i = 2 To Sheets.CountCells(i - 1, 1) = Sheets(i).Name'Sheets(1).Hyperlinks.Add Cells(i - 1, 1), "#" & Sheets(i).Name & "!A1" '添加超链接NextEnd Sub▲查另一文件的全部表名返回Sub 查另一文件的全部表名()On Error Resume NextDim i%Dim sh As WorksheetApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=ThisWorkbook.Path & "\2.xls"Windows("1.xls").Activate '当前文件名称Sheets("Sheet1").Select '当前表名称i = 1 '将表名称返回到第1行For Each sh In Workbooks("2.xls").WorksheetsCells(i, 1) = '将表名称返回到第1列i = i + 1 '返回每个表名称向下移动1行Next shWindows("2.xls").Close '关闭对象文件Application.ScreenUpdating = TrueEnd Sub▲当前单元录入计算机名返回Sub 当前单元录入计算机名()Selection = Environ("COMPUTERNAME")'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲当前单元录入计算机用户名返回 Sub 当前单元录入计算机用户名()Selection = Environ("Username")'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲解除全部工作表保护返回Sub 解除全部工作表保护()Dim n As IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext nEnd Sub▲为指定工作表加指定密码保护表返回Sub 为指定工作表加指定密码保护表()Sheet10.Protect Password:="123"End Sub▲在有密码的工作表执行代码返回Sub 在有密码的工作表执行代码()Sheets("1").Unprotect Password:=123 '假定表名为“1”，密码为“123” 打开工作表Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True '隐藏C列空值行Sheets("1").Protect Password:=123 '重新用密码保护工作表End Sub▲执行前需要验证密码的宏(控件按钮代码)返回Private Sub CommandButton1_Click()If InputBox("请输入密码：") <> "123" Then '密码是123MsgBox "密码错误,按确定退出!", 64, "提示"Exit SubEnd IfCells(1, 1) = 10End SubSub 执行前需要验证密码的宏()If InputBox("请输入您的使用权限:", "系统提示") = 123 Then重排窗口 '要执行的宏代码或宏名称ElseMsgBox "对不起,您没有使用该宏的权限,按确定键后退出!"End IfEnd Sub▲拷贝A1公式和格式到A2返回Sub 拷贝A1公式到A2()Workbooks("临时表").Sheets("表1").Range("A1").CopyWorkbooks("临时表").Sheets("表2").Range("A2").PasteSpecialEnd Sub▲复制单元数值返回Sub 复制数值()s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2")Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = sEnd Sub▲插入数值条件格式返回Sub 插入数值条件格式()Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="70"Selection.FormatConditions(1).Interior.ColorIndex = 45Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _Formula1:="55"Selection.FormatConditions(2).Interior.ColorIndex = 39Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="60"Selection.FormatConditions(3).Interior.ColorIndex = 34End Sub▲插入透明批注返回Sub 插入透明批注()Selection.AddCommentment.Visible = FalseDim XS As WorksheetFor i = 1 To ments.Countments(i).Text "透明批注"ments(i).Shape.Fill.Visible = msoFalseNextEnd Sub▲添加文本返回Sub 添加文本()Selection = Selection + "×" '不可在数字后添加文本'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲光标定位到指定工作表A列最后数据行下一单元返回Sub 光标定位到指定工作表A列最后数据行下一单元()a = Sheets("数据库").[a65536].End(xlUp).RowSheets("数据库").SelectRange("A" & a + 1).SelectEnd Sub▲定位选定单元格式相同的全部单元格返回Sub 定位选定单元格式相同的全部单元格()Dim FirstCell As Range, FoundCell As RangeDim AllCells As RangeWith Application.FindFormat.Clear.NumberFormatLocal = Selection.NumberFormatLocal.HorizontalAlignment = Selection.HorizontalAlignment.VerticalAlignment = Selection.VerticalAlignment.WrapText = Selection.WrapText.Orientation = Selection.Orientation.AddIndent = Selection.AddIndent.IndentLevel = Selection.IndentLevel.ShrinkToFit = Selection.ShrinkToFit.MergeCells = Selection.MergeCells = .Font.FontStyle = Selection.Font.FontStyle.Font.Size = Selection.Font.Size.Font.Strikethrough = Selection.Font.Strikethrough.Font.Subscript = Selection.Font.Subscript.Font.Underline = Selection.Font.Underline.Font.ColorIndex = Selection.Font.ColorIndex.Interior.ColorIndex = Selection.Interior.ColorIndex.Interior.Pattern = Selection.Interior.Pattern.Locked = Selection.Locked.FormulaHidden = Selection.FormulaHiddenEnd WithSet FirstCell = edRange.Find(what:="", searchformat:=True)If FirstCell Is Nothing ThenExit SubEnd IfSet AllCells = FirstCellSet FoundCell = FirstCellDoSet FoundCell = edRange.Find(After:=FoundCell, what:="",searchformat:=True)If FoundCell Is Nothing Then Exit DoSet AllCells = Union(FoundCell, AllCells)If FoundCell.Address = FirstCell.Address Then Exit DoLoopAllCells.SelectEnd Sub▲按当前单元文本定位返回Sub 按当前单元文本定位()ABC = SelectionDim aa As RangeFor Each a In edRangeIf a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲按固定文本定位返回Sub 文本定位()Dim aa As RangeFor Each a In edRangeIf a Like "*合计*" ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲删除包含固定文本单元的行或列返回Sub 删除包含固定文本单元的行或列()DoCells.Find(what:="哈哈").ActivateSelection.EntireRow.Delete '删除行' Selection.EntireColumn.Delete '删除列Loop Until Cells.Find(what:="哈哈") Is NothingEnd Sub▲定位数据及区域以上的空值返回Sub 定位数据及区域以上的空值()Dim aa As RangeFor Each a In edRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲右侧单元自动加5(工作表代码)返回Private Sub Worksheet_Change(ByVal Target As Range)Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd Sub▲当前单元加2返回Sub 当前单元加2()Selection = Selection + 2'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲A列等于A列减B列返回Sub A列等于A列减B列()For i = 1 To 23Cells(i, 1) = Cells(i, 1) - Cells(i, 2)NextEnd Sub▲用于光标选定多区域跳转指定单元(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal T As Range)a = Array([b6:b7], [e6], [h6])For i = 0 To 2If Not Application.Intersect(T, a(i)) Is Nothing Then[a1].Select: Exit ForEnd IfNextEnd Sub▲将A1单元录入的数据累加到B1单元（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)Dim t As LongIf Target.Address = "$A$1" Thent = Sheet1.Range("$B$1").ValueSheet1.Range("$B$1").Value = t + Target.ValueEnd IfEnd Sub▲在指定颜色区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> "√", "√", "")NextEnd Sub▲在指定区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target, Range("D6:D20")) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = "" Then.Value = "√"Else.Value = ""End IfEnd WithNextEnd IfEnd IfEnd Sub▲双击指定单元，循环录入文本（工作表代码）返回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双击指定单元，循环录入文本（工作表代码）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▲单元区域引用（工作表代码）返回Private Sub Worksheet_Activate()Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").ValueEnd Sub▲在指定区域选择单元时数值加1（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect([a1:e10], Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub▲混合文本的编号返回Sub 混合文本的编号()Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3,100)) + 1)End Sub▲指定区域单元双击数据累加（工作表代码）返回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▲选择单元区域触发事件（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = "$A$1:$B$2" ThenMsgBox "你选择了$A$1:$B$2单元"End IfEnd Sub▲当修改指定单元内容时自动执行宏（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then重排窗口End IfEnd Sub▲被指定单元内容限制执行宏返回Sub 被指定单元限制执行宏()If Range("$A$1") = "关闭" Then Exit Sub窗口End Sub▲双击单元隐藏该行（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Rows(Target.Row).Hidden = TrueEnd Sub▲高亮显示行（工作表代码）返回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▲高亮显示行和列（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34Columns(Target.Column).Interior.ColorIndex = 34End Sub▲为指定工作表设置滚动范围（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)Sheet1.ScrollArea = "A1:M30"End Sub▲在指定单元记录打印和预览次数（工作簿代码）返回Private Sub Workbook_BeforePrint(Cancel As Boolean)Range("A1") = 1 + Range("A1")End Sub▲自动数字金额转大写（工作表代码）返回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 * 100f = (j / 10 - Int(j / 10)) * 10A = 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▲将全部工作表的A1单元作为单击按钮（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)If Target.Address = "$A$1" ThenCall 宏名End IfEnd Sub▲闹钟——到指定时间执行宏（工作簿代码）返回Private Sub Workbook_Open()Application.OnTime ("11:45:00"), "提示1" '宏名字Application.OnTime ("12:00:00"), "提示2" '宏名字End Sub▲改变Excel界面标题的宏（工作簿代码）返回Private Sub Workbook_Open()Application.Caption = "春节快乐"End Sub▲在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)Worksheets("表2").Range("A1") = Target.Address(0, 0)End Sub▲B列录入数据时在A列返回记录时间（工作表代码）返回Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub▲当指定区域修改时在其右侧的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▲指定单元显示光标位置内容（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal T As Range)Sheets(1).Range("A1") = SelectionEnd Sub▲每编辑一个单元保存文件返回Private Sub Worksheet_Change(ByVal Target As Range)ThisWorkbook.SaveEnd Sub▲指定允许编辑区域返回Sub 指定允许编辑区域()ActiveSheet.ScrollArea = "B8:G15"End Sub▲解除允许编辑区域限制返回Sub 解除允许编辑区域限制()ActiveSheet.ScrollArea = ""End Sub▲删除指定行返回Sub 删除指定行()Workbooks("临时表").Sheets("表2").Range("5:5").DeleteEnd Sub▲删除A列为指定内容的行返回Sub 删除A列为指定内容的行()Dim a, b As Integera = Sheet1.[a65536].End(xlUp).RowFor b = a To 2 Step -1If Cells(b, 1).Value = "删除" ThenRows(b).DeleteEnd IfNextEnd Sub▲删除A列非数字单元行返回Sub 删除A列非数字单元行()i = [a65536].End(xlUp).RowRange("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.DeleteEnd Sub▲有条件删除当前行返回Sub 有条件删除当前行()If [A1] = 2 Or [B1] = "删除" ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub▲选择下一行返回Sub 选择下一行()ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.SelectEnd Sub▲选择第5行开始所有数据行返回Sub 选择第5行开始所有数据行A()Dim i%i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues,SearchDirection:=xlPrevious).EntireRow.RowRows("5:" & i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows("5:" & Cells.Find("*", , , , 1, 2).Row).SelectEnd Sub▲选择光标或选区所在行返回Sub 选择光标或选区所在行()Selection.EntireRow.Select▲选择光标或选区所在列返回Sub 选择光标或选区所在列()Selection.EntireColumn.SelectEnd Sub▲光标定位到名称指定位置返回Sub 定位()Application.Goto Range(Evaluate("名称"))End Sub▲选择名称定义的数据区返回Sub 选择名称定义的数据区()[数据区].Select '插入名称要使用INDIRECT函数'Range("数据区").Select 或者'Sheet1.Range("数据区").Select 或者End Sub▲选择到指定列的最后行返回Sub 选择到指定列的最后行()Range("C4:G" & [G65536].End(xlUp).Row).SelectEnd Sub▲将Sheet1的A列的非空值写到Sheet2的A列返回Sub 将Sheet1的A列的非空值写到Sheet2的A列()Sheet1.Columns("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1]End Sub▲将名称1的数据写到名称2返回Sub Macro2()Range("位置2") = Range("位置1").Value▲单元反选返回Sub 单元反选()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress As String, taddress As Stringraddress = Selection.Addresstaddress = edRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = "=0"raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address.DeleteEnd WithActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub▲调整选中对象中的文字返回Sub 调整选中对象中的文字()'文字居中、自动调整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd WithEnd Sub▲去除指定范围内的对象返回Sub 去除指定范围内的对象()。
Excel-vba宏代码-大全
Excel-vba宏代码-大全宏文件集▲打开全部隐藏工作表返回Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = TrueNext iEnd Sub▲循环宏返回Sub 循环()AAA = Range("C2")Dim i As LongDim times As Longtimes = AAA'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range("完成标志") = "完成" Then Exit For '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则只执行一次循环就退出'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For '如果某列出现"完成"内容则退出循环Next iEnd Sub▲录制宏时调用“停止录制”工具栏返回Sub 录制宏时调用停止录制工具栏()/doc/4911298482.html,mandBars("Stop Recording").Visible = TrueEnd Sub▲高级筛选5列不重复数据至指定表返回Sub 高级筛选5列不重复数据至Sheet2()Sheets("Sheet2").Range("A1:E65536") = "" '清除Sheet2的A:D 列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _"A1"), Unique:=TrueSheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"), Order1:=xlAscending,Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub▲双击单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$4"Call 宏1Cancel = TrueCase "$B$4"Call 宏2Cancel = TrueCase "$C$4"Call 宏3Cancel = TrueCase "$E$4"Call 宏4Cancel = TrueEnd SelectEnd Sub▲双击指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then Call 打开隐藏表End Sub▲进入单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)'以单元格进入代替按钮对象调用宏If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$5" '单元地址(Target.Address),或命名单元名字(/doc/4911298482.html,)Call 宏1Case "$B$5"Call 宏2Case "$C$5"Call 宏3End SelectEnd Sub▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call打开隐藏表▲在多个宏中依次循环执行一个（控件按钮代码）返回Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub▲在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()With CommandButton1If .Caption = "保护工作表" ThenCall 保护工作表.Caption = "取消工作表保护"Exit SubEnd IfIf .Caption = "取消工作表保护" ThenCall 取消工作表保护.Caption = "保护工作表"Exit SubEnd IfEnd With▲在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = "宏1" ThenCall 宏1.Caption = "宏2"Exit SubEnd IfIf .Caption = "宏2" ThenCall 宏2.Caption = "宏3"Exit SubEnd IfIf .Caption = "宏3" ThenCall 宏3.Caption = "宏1"Exit SubEnd IfEnd WithEnd Sub▲根据A1单元文本隐藏/显示按钮（控件按钮代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range("A1") > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub▲当前单元返回按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub▲当前单元内容返回到按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub▲奇偶页分别打印返回Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数MsgBox "现在打印奇数页,按确定开始."For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox "现在打印偶数页,按确定开始."For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub▲自动打印多工作表第一页返回Sub 自动打印多工作表第一页() Dim sh As IntegerDim xDim yDim syDim syzx = InputBox("请输入起始工作表名字:")sy = InputBox("请输入结束工作表名字:")y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub▲查找A列文本循环插入分页符返回Sub 循环插入分页符()' Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页")'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.AddBefore:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub▲将A列最后数据行以上的所有B列图片大小调整为所在单元大小返回Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing ThenPic.Top = Pic.T opLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub▲返回光标所在行数返回Sub 返回光标所在行数()x = ActiveCell.RowRange("A1") = xEnd Sub▲在A1返回当前选中单元格数量返回Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub▲返回当前工作簿中工作表数量返回Sub 返回当前工作簿中工作表数量()t = Application.Sheets.CountMsgBox tEnd Sub▲返回光标选择区域的行数和列数返回Sub 返回光标选择区域的行数和列数()x = Selection.Rows.County = Selection.Columns.CountRange("A1") = xRange("A2") = yEnd Sub▲工作表中包含数据的最大行数返回Sub 包含数据的最大行数()n = Cells.Find("*", , , , 1, 2).RowMsgBox nEnd Sub▲返回A列数据的最大行数返回Sub 返回A列数据的最大行数() n = Range("a65536").End(xlUp).RowRange("B1") = nEnd Sub▲将所选区域文本插入新建文本框返回Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizon tal, ActiveCell.Left +ActiveCell.Width, ActiveCell.T op + ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = "问题：" & nWith Selection.Characters(Start:=1, Length:=3).Font.Name = "黑体".FontStyle = "常规".Size = 12End WithEnd Sub▲批量插入地址批注返回Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selection/doc/4911298482.html,ment.Deleter.AddComment/doc/4911298482.html,ment.Visible = False /doc/4911298482.html,ment.Text Text:="本单元格：" & r.Address & " of " & Selection.AddressNextEnd IfEnd Sub▲批量插入统一批注返回Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddComment/doc/4911298482.html,ment.Visible = False /doc/4911298482.html,ment.TextText:=msgNextEnd IfEnd Sub▲以A1单元内容批量插入批注返回Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddComment/doc/4911298482.html,ment.Visible = False /doc/4911298482.html,ment.TextText:=[a1].T extNextEnd IfEnd Sub▲不连续区域插入当前文件名和表名及地址返回Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = "[" + /doc/4911298482.html, + "]" + /doc/4911298482.html, +"!" + mycell.AddressNextEnd Sub▲不连续区域录入当前单元地址返回Sub 区域录入当前单元地址() For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub▲连续区域录入当前单元地址返回Sub 连续区域录入当前单元地址()Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub▲返回当前单元地址返回Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub▲不连续区域录入当前日期返回Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")End Sub▲不连续区域录入当前数字日期返回Sub 区域录入当前数字日期() Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")End Sub▲不连续区域录入当前日期和时间返回Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")End Sub▲不连续区域录入对勾返回Sub 批量录入对勾()Selection.FormulaR1C1 = "√"End Sub▲不连续区域录入当前文件名返回Sub 批量录入当前文件名()Selection.FormulaR1C1 = /doc/4911298482.html,End Sub▲不连续区域添加文本返回Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & "文本内容"NextEnd Sub▲不连续区域插入文本返回Sub 批量插入文本()Dim s As RangeFor Each s In Selections = "文本内容" & sNextEnd Sub▲从指定位置向下同时录入多单元指定内容返回Sub 从指定位置向下同时录入多单元指定内容()Dim arrarr = Array("1", "2", "13", "25", "46", "12", "0", "20")[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub▲按aa工作表A列的内容排列工作表标签顺序返回Sub 按aa工作表A列的内容排列工作表标签顺序()Dim I%, str1$I = 1Sheets("aa").SelectDo While Cells(I, 1).Value <> ""str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets("aa").SelectLoopEnd Sub▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add/doc/4911298482.html, = nmEnd Sub▲删除全部未选定工作表返回Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As BooleanDim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = /doc/4911298482.html,n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n - 1If ShtName(i) = /doc/4911298482.html, TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub▲工作表标签排序返回Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox("工作表按升序排列请选'是[Y]'. " & vbCrLf & vbCrLf & "工作表按降序排列请选 '否[N]'", vbYesNoCancel, "工作表排序")If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then 'Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse 'Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub▲定义指定工作表标签颜色返回Sub 定义指定工作表标签颜色() Sheets("Sheet1").T ab.ColorIndex = 46End Sub▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets("目录").ActivateIf Err = 0 ThenSheets("目录").UsedRange.DeleteElseSheets.Add/doc/4911298482.html, = "目录" End If。
EXCEL常用宏大全
打开全部隐藏工作表Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = TrueNext iEnd Sub循环宏Sub 循环()AAA = Range(“C2″)Dim i As LongDim times As Longtimes = AAA‘times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647) For i = 1 To timesCall 过滤一行If Range(“完成标志”) = “完成”Then Exit For ‘如果名为’完成标志’的命名单元的值等于’完成’,则退出循环,如果一开始就等于’完成’,则只执行一次循环就退出‘If Sheets(“传送参数”).Range(“A”& i).Text = “完成”Then Exit For ’如果某列出现”完成”内容则退出循环Next iEnd Sub录制宏时调用“停止录制”工具栏Sub 录制宏时调用停止录制工具栏()mandBars(“Stop Recording”).Visible = TrueEnd Sub高级筛选5列不重复数据至指定表Sub 高级筛选5列不重复数据至Sheet2()Sheets(“Sheet2″).Range(“A1:E65536″) = “”‘清除Sheet2的A:D列Range(“A1:E65536″).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _“A1″), Unique:=TrueSheet2.Columns(“A:E”).Sort Key1:=Sheet2.Range(“A2″), Order1:=xlAscending, Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub双击单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range(“$A$1″) = “关闭”Then Exit SubSelect Case Target.AddressCase “$A$4″Call 宏1Cancel = TrueCase “$B$4″Call 宏2Cancel = TrueCase “$C$4″Call 宏3Cancel = TrueCase “$E$4″Call 宏4Cancel = TrueEnd SelectEnd Sub双击指定区域单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range(“$A$1″) = “关闭”Then Exit SubIf Not Application.Intersect(Target, Range(“A4:A9″, “C4:C9″)) Is Nothing Then Call 打开隐藏表End Sub进入单元执行宏(工作表代码)Private Sub Worksheet_SelectionChange(ByVal Target As Range)‘以单元格进入代替按钮对象调用宏If Range(“$A$1″) = “关闭”Then Exit SubSelect Case Target.AddressCase “$A$5″‘单元地址(Target.Address),或命名单元名字()Call 宏1Case “$B$5″Call 宏2Case “$C$5″Call 宏3End SelectEnd Sub进入指定区域单元执行宏(工作表代码)Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range(“$A$1″) = “关闭”Then Exit SubIf Not Application.Intersect(Target, Range(“A4:A9″,”C4:C9″)) Is Nothing Then Call 打开隐藏表End Sub在多个宏中依次循环执行一个（控件按钮代码）Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Private Sub CommandButton1_Click()With CommandButton1If .Caption = “保护工作表”ThenCall 保护工作表.Caption = “取消工作表保护”Exit SubEnd IfIf .Caption = “取消工作表保护”ThenCall 取消工作表保护.Caption = “保护工作表”Exit SubEnd IfEnd WithEnd Sub在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = “宏1″ThenCall 宏1.Caption = “宏2″Exit SubEnd IfIf .Caption = “宏2″ThenCall 宏2.Caption = “宏3″Exit SubEnd IfIf .Caption = “宏3″ThenCall 宏3.Caption = “宏1″Exit SubEnd IfEnd WithEnd Sub根据A1单元文本隐藏/显示按钮（控件按钮代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range(“A1″) > 2 ThenCommandButton1.Visible = 1CommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub当前单元返回按钮名称（控件按钮代码）Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub当前单元内容返回到按钮名称（控件按钮代码）Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub奇偶页分别打印Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro(“GET.DOCUMENT(50)”) ‘总页数MsgBox “现在打印奇数页,按确定开始.”For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iMsgBox “现在打印偶数页,按确定开始.”For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=i Next iEnd Sub自动打印多工作表第一页Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx = InputBox(“请输入起始工作表名字:”) sy = InputBox(“请输入结束工作表名字:”) y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub查找A列文本循环插入分页符Sub 循环插入分页符()‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range(“a:a”), “分页”) ‘times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647) For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:=”分页”, After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub将A列最后数据行以上的所有B列图片大小调整为所在单元大小Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小() Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range(“B1:B” & i)) Is Nothing Then Pic.Top = Pic.TopLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub返回光标所在行数Sub 返回光标所在行数()x = ActiveCell.RowRange(“A1″) = xEnd Sub在A1返回当前选中单元格数量Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub返回当前工作簿中工作表数量Sub 返回当前工作簿中工作表数量() t = Application.Sheets.CountMsgBox tEnd Sub返回光标选择区域的行数和列数Sub 返回光标选择区域的行数和列数() x = Selection.Rows.County = Selection.Columns.CountRange(“A1″) = xRange(“A2″) = yEnd Sub工作表中包含数据的最大行数Sub 包含数据的最大行数()n = Cells.Find(“*”, , , , 1, 2).Row MsgBox nEnd Sub返回A列数据的最大行数Sub 返回A列数据的最大行数()n = Range(“a65536″).End(xlUp).Row Range(“B1″) = nEnd Sub将所选区域文本插入新建文本框Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = “问题：”& nWith Selection.Characters(Start:=1, Length:=3).Font.Name = “黑体”.FontStyle = “常规”.Size = 12End WithEnd Sub批量插入地址批注Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionment.Deleter.AddCommentment.Visible = Falsement.Text Text:=”本单元格：”& r.Address & ”of ”& Selection.Address NextEnd IfEnd Sub批量插入统一批注Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox(“请输入欲批量插入的批注”, “提示”, “随便输点什么吧”) If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=msgNextEnd IfEnd Sub以A1单元内容批量插入批注Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=[a1].TextNextEnd IfEnd Sub不连续区域插入当前文件名和表名及地址Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = “*" + + "+” + + “!” + mycell.AddressNextEnd Sub不连续区域录入当前单元地址Sub 区域录入当前单元地址()For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub连续区域录入当前单元地址Sub 连续区域录入当前单元地址()Selection = “=ADDRESS(ROW(),COLUMN(),4,1)”Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub返回当前单元地址Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub不连续区域录入当前日期Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), “yyyy-m-d”)End Sub不连续区域录入当前数字日期Sub 区域录入当前数字日期()Selection.FormulaR1C1 = Format(Now(), “yyyymmdd”)End Sub不连续区域录入当前日期和时间Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), “yyyy-m-d h:mm:ss”) End Sub不连续区域录入对勾Sub 批量录入对勾()Selection.FormulaR1C1 = “√”End Sub不连续区域录入当前文件名Sub 批量录入当前文件名()Selection.FormulaR1C1 = End Sub不连续区域添加文本Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & “文本内容”NextEnd Sub不连续区域插入文本Sub 批量插入文本()Dim s As RangeFor Each s In Selections = “文本内容”& sNextEnd Sub从指定位置向下同时录入多单元指定内容Sub 从指定位置向下同时录入多单元指定内容() Dim arrarr = Array(“1″, “2″, “13″, “25″, “46″, “12″, “0″, “20″) [B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub按aa工作表A列的内容排列工作表标签顺序Sub 按aa工作表A列的内容排列工作表标签顺序()Dim I%, str1$I = 1Sheets(“aa”).SelectDo While Cells(I, 1).Value <> “”str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets(“aa”).SelectLoopEnd Sub以A1单元文本作表名插入工作表Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add = nmEnd Sub删除全部未选定工作表Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As Boolean Dim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n – 1If ShtName(i) = TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub工作表标签排序Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox(“工作表按升序排列请选‘是[Y]‘. ”& vbCrLf & vbCrLf & “工作表按降序排列请选‘否[N]‘”, vbYesNoCancel, “工作表排序”)If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then ‘Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse ‘Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub定义指定工作表标签颜色Sub 定义指定工作表标签颜色()Sheets(“Sheet1″).Tab.ColorIndex = 46End Sub在目录表建立本工作簿中各表链接目录Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets(“目录”).ActivateIf Err = 0 ThenSheets(“目录”).UsedRange.DeleteElseSheets.Add = “目录”End IfFor i = 1 To Sheets.CountIf Sheets(i).Name <> “目录”Thens = s + 1Set Rng = Sheets(“目录”).Cells(((s –1) Mod 20) + 1, (s –1) \ 20 + 1 + 1)Rng = Format(s, ”0″) & “. ”& Sheets(i).NameActiveSheet.Hyperlinks.Add Rng, “#”& Sheets(i).Name & “!A1″, ScreenTip:=Sheets(i).NameEnd IfNextSheets(“目录”).Range(“b:iv”).EntireColumn.ColumnWidth = 20End Sub建立工作表文本目录Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)Sheets(1).Name = “目录”For i = 2 To Sheets.CountCells(i – 1, 1) = Sheets(i).Name‘Sheets(1).Hyperlinks.Add Cells(i –1, 1), “#”& Sheets(i).Name & “!A1″‘添加超链接NextEnd Sub查另一文件的全部表名Sub 查另一文件的全部表名()On Error Resume NextDim i%Dim sh As WorksheetApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=ThisWorkbook.Path & “\2.xls”Windows(“1.xls“).Activate ‘当前文件名称Sheets(“Sheet1“).Select ‘当前表名称i = 1 ’将表名称返回到第1行For Each sh In Workbooks(“2.xls”).WorksheetsCells(i, 1) = ‘将表名称返回到第1列i = i + 1 ‘返回每个表名称向下移动1行Next shWindows(“2.xls”).Close ‘关闭对象文件Application.ScreenUpdating = TrueEnd Sub当前单元录入计算机名Sub 当前单元录入计算机名()Selection = Environ(“COMPUTERNAME”)‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End Sub当前单元录入计算机用户名Sub 当前单元录入计算机用户名()Selection = Environ(“Username”)‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End Sub解除全部工作表保护Sub 解除全部工作表保护()Dim n As IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext nEnd Sub为指定工作表加指定密码保护表Sub 为指定工作表加指定密码保护表()Sheet10.Protect Password:=”123″End Sub在有密码的工作表执行代码Sub 在有密码的工作表执行代码()Sheets(“1″).Unprotect Password:=123 ‘假定表名为“1”，密码为“123”打开工作表Range(“C:C”).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True ‘隐藏C列空值行Sheets(“1″).Protect Password:=123 ‘重新用密码保护工作表End Sub执行前需要验证密码的宏(控件按钮代码)Private Sub CommandButton1_Click()If InputBox(“请输入密码：”) <> “123″Then ‘密码是123MsgBox “密码错误,按确定退出!”, 64, “提示”Exit SubEnd IfCells(1, 1) = 10End SubSub 执行前需要验证密码的宏()If InputBox(“请输入您的使用权限:”, “系统提示”) = 123 Then重排窗口‘要执行的宏代码或宏名称ElseMsgBox “对不起,您没有使用该宏的权限,按确定键后退出!”End IfEnd Sub拷贝A1公式和格式到A2Sub 拷贝A1公式到A2()Workbooks(“临时表”).Sheets(“表1″).Range(“A1″).Copy Workbooks(“临时表”).Sheets(“表2″).Range(“A2″).PasteSpecial End Sub复制单元数值Sub 复制数值()s = Workbooks(“book1″).Sheets(“Sheet1″).Range(“A1:A2″) Workbooks(“book2″).Sheets(“Sheet1″).Range(“A1:A2″) = s End Sub插入数值条件格式Sub 插入数值条件格式()Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:=”70″Selection.FormatConditions(1).Interior.ColorIndex = 45Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _ Formula1:=”55″Selection.FormatConditions(2).Interior.ColorIndex = 39Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:=”60″Selection.FormatConditions(3).Interior.ColorIndex = 34End Sub插入透明批注Sub 插入透明批注()Selection.AddCommentment.Visible = FalseDim XS As WorksheetFor i = 1 To ments.Countments(i).Text “透明批注”ments(i).Shape.Fill.Visible = msoFalseNextEnd Sub添加文本Sub 添加文本()Selection = Selection + “×”‘不可在数字后添加文本‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End Sub光标定位到指定工作表A列最后数据行下一单元Sub 光标定位到指定工作表A列最后数据行下一单元()a = Sheets(“数据库”).[a65536].End(xlUp).RowSheets(“数据库”).SelectRange(“A” & a + 1).SelectEnd Sub定位选定单元格式相同的全部单元格Sub 定位选定单元格式相同的全部单元格()Dim FirstCell As Range, FoundCell As RangeDim AllCells As RangeWith Application.FindFormat.Clear.NumberFormatLocal = Selection.NumberFormatLocal.HorizontalAlignment = Selection.HorizontalAlignment.VerticalAlignment = Selection.VerticalAlignment.WrapText = Selection.WrapText.Orientation = Selection.Orientation.AddIndent = Selection.AddIndent.IndentLevel = Selection.IndentLevel.ShrinkToFit = Selection.ShrinkToFit.MergeCells = Selection.MergeCells = .Font.FontStyle = Selection.Font.FontStyle.Font.Size = Selection.Font.Size.Font.Strikethrough = Selection.Font.Strikethrough.Font.Subscript = Selection.Font.Subscript.Font.Underline = Selection.Font.Underline.Font.ColorIndex = Selection.Font.ColorIndex.Interior.ColorIndex = Selection.Interior.ColorIndex.Interior.Pattern = Selection.Interior.Pattern.Locked = Selection.Locked.FormulaHidden = Selection.FormulaHiddenEnd WithSet FirstCell = edRange.Find(what:=”", searchformat:=True) If FirstCell Is Nothing ThenExit SubEnd IfSet AllCells = FirstCellSet FoundCell = FirstCellDoSet FoundCell = edRange.Find(After:=FoundCell, what:=”", searchformat:=True)If FoundCell Is Nothing Then Exit DoSet AllCells = Union(FoundCell, AllCells)If FoundCell.Address = FirstCell.Address Then Exit DoLoopAllCells.SelectEnd Sub按当前单元文本定位Sub 按当前单元文本定位()ABC = SelectionDim aa As RangeFor Each a In edRangeIf a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub按固定文本定位Sub 文本定位()Dim aa As RangeFor Each a In edRangeIf a Like “*合计*”ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub删除包含固定文本单元的行或列Sub 删除包含固定文本单元的行或列() DoCells.Find(what:=”哈哈”).Activate Selection.EntireRow.Delete ‘删除行‘Selection.EntireColumn.Delete ‘删除列Loop Until Cells.Find(what:=”哈哈”) Is Nothing End Sub定位数据及区域以上的空值Sub 定位数据及区域以上的空值()Dim aa As RangeFor Each a In edRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub右侧单元自动加5(工作表代码)Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd Sub当前单元加2Sub 当前单元加2()Selection = Selection + 2‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End SubA列等于A列减B列Sub A列等于A列减B列()For i = 1 To 23Cells(i, 1) = Cells(i, 1) – Cells(i, 2)NextEnd Sub用于光标选定多区域跳转指定单元(工作表代码)Private Sub Worksheet_SelectionChange(ByVal T As Range)a = Array([b6:b7], [e6], [h6])For i = 0 To 2If Not Application.Intersect(T, a(i)) Is Nothing Then[a1].Select: Exit ForEnd IfNextEnd Sub将A1单元录入的数据累加到B1单元（工作表代码）Private Sub Worksheet_Change(ByVal Target As Range)Dim t As LongIf Target.Address = “$A$1″Thent = Sheet1.Range(“$B$1″).ValueSheet1.Range(“$B$1″).Value = t + Target.ValueEnd IfEnd Sub在指定颜色区域选择单元时添加/取消”√”（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> “√”, “√”, “”) NextEnd Sub在指定区域选择单元时添加/取消”√”（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target, Range(“D6:D20″)) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = “” Then.Value = “√”Else.Value = “”End IfEnd WithNextEnd IfEnd IfEnd Sub双击指定单元，循环录入文本（工作表代码）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双击指定单元，循环录入文本（工作表代码）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单元区域引用（工作表代码）Private Sub Worksheet_Activate()Sheet1.Range(“A1:B3″).Value = Sheet2.Range(“A1:B3″).ValueEnd Sub在指定区域选择单元时数值加1（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect([a1:e10], Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub混合文本的编号Sub 混合文本的编号()Worksheets(1).Range(“B2″).Value = “北京”& (–(Mid(Worksheets(1).Range(“B2″), 3, 100)) + 1)End Sub指定区域单元双击数据累加（工作表代码）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 Sub选择单元区域触发事件（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = “$A$1:$B$2″ThenMsgBox “你选择了$A$1:$B$2单元”End IfEnd Sub当修改指定单元内容时自动执行宏（工作表代码）Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then重排窗口End IfEnd Sub被指定单元内容限制执行宏Sub 被指定单元限制执行宏()If Range(“$A$1″) = “关闭”Then Exit Sub窗口End Sub双击单元隐藏该行（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Rows(Target.Row).Hidden = True高亮显示行（工作表代码）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,15 End Sub高亮显示行和列（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34Columns(Target.Column).Interior.ColorIndex = 34End Sub为指定工作表设置滚动范围（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Sheet1.ScrollArea = “A1:M30″End Sub在指定单元记录打印和预览次数（工作簿代码）Private Sub Workbook_BeforePrint(Cancel As Boolean)Range(“A1″) = 1 + Range(“A1″)End Sub自动数字金额转大写（工作表代码）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 * 100f = (j / 10 – Int(j / 10)) * 10A = 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将全部工作表的A1单元作为单击按钮（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)If Target.Address = “$A$1″ThenCall 宏名End IfEnd Sub闹钟——到指定时间执行宏（工作簿代码）Private Sub Workbook_Open()Application.OnTime (“11:45:00″), “提示1″‘宏名字Application.OnTime (“12:00:00″), “提示2″‘宏名字End Sub改变Excel界面标题的宏（工作簿代码）Private Sub Workbook_Open()Application.Caption = “春节快乐”End Sub在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Worksheets(“表2″).Range(“A1″) = Target.Address(0, 0)End SubB列录入数据时在A列返回记录时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub当指定区域修改时在其右侧的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 Then If Target.Column = 1 ThenTarget.Offset(, 1) = Format(Now(), “yyyy-mm-dd”)Target.Offset(, 2) = Format(Now(), “h:mm:ss”)End IfEnd IfEnd Sub指定单元显示光标位置内容（工作表代码）Private Sub Worksheet_SelectionChange(ByVal T As Range) Sheets(1).Range(“A1″) = SelectionEnd Sub每编辑一个单元保存文件Private Sub Worksheet_Change(ByVal Target As Range) ThisWorkbook.SaveEnd Sub指定允许编辑区域Sub 指定允许编辑区域()ActiveSheet.ScrollArea = “B8:G15″End Sub解除允许编辑区域限制Sub 解除允许编辑区域限制()ActiveSheet.ScrollArea = “”End Sub删除指定行Sub 删除指定行()Workbooks(“临时表”).Sheets(“表2″).Range(“5:5″).Delete End Sub删除A列为指定内容的行Sub 删除A列为指定内容的行()Dim a, b As Integera = Sheet1.[a65536].End(xlUp).RowFor b = a To 2 Step -1If Cells(b, 1).Value = “删除”ThenRows(b).DeleteEnd IfNextEnd Sub删除A列非数字单元行Sub 删除A列非数字单元行()i = [a65536].End(xlUp).RowRange(“A1:A” & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End Sub有条件删除当前行Sub 有条件删除当前行()If [A1] = 2 Or [B1] = “删除”ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub选择下一行Sub 选择下一行()ActiveCell.Offset(1, 0).Rows(“1:1″).EntireRow.SelectEnd Sub选择第5行开始所有数据行Sub 选择第5行开始所有数据行A()Dim i%i = Cells.Find(“*”, SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).EntireRow.RowRows(“5:” & i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows(“5:” & Cells.Find(“*”, , , , 1, 2).Row).SelectEnd Sub选择光标或选区所在行Sub 选择光标或选区所在行()Selection.EntireRow.Select选择光标或选区所在列Sub 选择光标或选区所在列()Selection.EntireColumn.SelectEnd Sub光标定位到名称指定位置Sub 定位()Application.Goto Range(Evaluate(“名称”))End Sub选择名称定义的数据区Sub 选择名称定义的数据区()[数据区].Select ‘插入名称要使用INDIRECT函数‘Range(“数据区”).Select 或者‘Sheet1.Range(“数据区”).Select 或者End Sub选择到指定列的最后行Sub 选择到指定列的最后行()Range(“C4:G” & *G65536+.End(xlUp).Row).SelectEnd Sub将Sheet1的A列的非空值写到Sheet2的A列Sub 将Sheet1的A列的非空值写到Sheet2的A列()Sheet1.Columns(“A:A”).SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.*A1+将名称1的数据写到名称2Sub Macro2()Range(“位置2″) = Range(“位置1″).ValueEnd Sub单元反选Sub 单元反选()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress As String, taddress As Stringraddress = Selection.Addresstaddress = edRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = “=0″raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address .DeleteEnd WithActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub调整选中对象中的文字Sub 调整选中对象中的文字()‘文字居中、自动调整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd WithEnd Sub去除指定范围内的对象Sub 去除指定范围内的对象()Dim p As ShapeSet My = Worksheets(“工作表名“)For Each p In My.ShapesIf Not Application.Intersect(p.TopLeftCell, Range(“范围”)) Is Nothing Then p.Delete NextEnd Sub更新透视表数据项Sub DeleteMissingItems2002All()‘防止数据透视表中显示无用的数据项‘在Excel 2002 或更高版本中‘如果无用的数据项已经存在,‘运行这个宏可以更新Dim pt As PivotTableDim ws As WorksheetFor Each ws In ActiveWorkbook.WorksheetsFor Each pt In ws.PivotTablespt.PivotCache.MissingItemsLimit = xlMissingItemsNone Next ptNext wsEnd Sub将全部工作表名称写到A列Sub 将全部表名称写到A列()k = 1For Each Sht In SheetsCells(k + 1, 1) = ‘指定写入的行和列k = k + 1NextEnd Sub为当前选定的多单元插入指定名称Sub 为当前选定的多单元插入指定名称() = “临时”s.Add Name:=”临时”, RefersTo:=Selection ‘或者换用这行代码也可以End Sub删除全部名称Sub 删除全部名称()On Error Resume NextDim l As Integerl = s.CountFor i = l To 1 Step -1s(i).DeleteNextEnd Sub以指定区域为表目录补充新表Sub 以指定区域为表目录补充新表()Dim dic As Object, sh As WorksheetDim arr, itemarr = Range(“B1:BB1″)Set dic = CreateObject(“scripting.dictionary”)For Each sh In ThisWorkbook.Worksheetsdic.Add , “”NextFor Each item In arrIf item <> “” And Not dic.exists(Trim(item)) ThenWith ThisWorkbook.Worksheets.Add.Name = itemEnd WithEnd IfNextSet dic = NothingEnd Sub按A列数据批量修改表名称Sub 按A列数据批量修改表名称()Dim i%For i = 1 To Sheets.Count – 1Sheets(i).Name = Cells(i + 1, 1).Text NextEnd Sub按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清除剪贴板Sub 清除剪贴板()Application.CutCopyMode = FalsemandBars(“Task Pane”).Visible = FalseEnd Sub批量清除软回车Sub 批量清除软回车()‘也可直接使用Alt+10或13替换Cells.Replace What:=Chr(10), Replacement:=”", LookAt:=xlPart, SearchOrder:= _ xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub判断指定文件是否已经打开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:\信件\”& End Sub另存指定文件名Sub 另存指定文件名()ActiveWorkbook.SaveAs ThisWorkbook.Path & “\别名.xls”End Sub以本工作表名称另存文件到当前目录Sub 以本工作表名称另存文件到当前目录()ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & “\” & & “.xls”End Sub将本工作表单独另存文件到Excel当前默认目录Sub 将本工作表单独另存文件到Excel当前默认目录()ActiveSheet.CopyActiveWorkbook.SaveAs Filename:= & “.xls”End Sub。
excel常用宏
1.拆分单元格赋值Sub 拆分填充()Dim x As RangeFor Each x In edRange.CellsIf x.MergeCells Thenx.Selectx.UnMergeSelection.Value = x.ValueEnd IfNext xEnd Sub2.E xcel 宏按列拆分多个excelSub Macro1()Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i& Set rng = Range("A1:f1")Application.ScreenUpdating = FalseApplication.DisplayAlerts = Falsearr = Range("a1:a" & Range("b" & Cells.Rows.Count).End(xlUp).Row)Set d = CreateObject("scripting.dictionary")For i = 2 To UBound(arr)If Not d.Exists(arr(i, 1)) ThenSet d(arr(i, 1)) = Cells(i, 1).Resize(1, 13)ElseSet d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 13)) End IfNextk = d.Keyst = d.ItemsFor i = 0 To d.Count - 1Set wb = Workbooks.Add(xlWBATWorksheet)With wb.Sheets(1)rng.Copy .[A1]t(i).Copy .[A2]End Withwb.SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xlsx"wb.CloseNextApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueMsgBox "完毕"End Sub3.E xcel 宏按列拆分多个sheet在一个工作表中是许多的公司订单记录，如何将它按公司名分拆成一个个工作表，用VBA 实现相当便捷。
EXCEL常用的233个宏
代码目录链接类别打开全部隐藏工作表点击循环宏点击录制宏时调用“停止录制”工具栏点击高级筛选5列不重复数据至指定表点击在多个宏中依次循环执行一个（控件按钮代码）点击在两个宏中依次循环执行一个并相应修改按钮名称点击（控件按钮代码）在三个宏中依次循环执行一个并相应修改按钮名称点击（控件按钮代码）根据A1单元文本隐藏/显示按钮（控件按钮代码）点击当前单元返回按钮名称（控件按钮代码）点击当前单元内容返回到按钮名称（控件按钮代码）点击奇偶页分别打印点击打印自动打印多工作表第一页点击打印查找A列文本循环插入分页符点击打印将A列最后数据行以上的所有B列图片大小调整为所在点击对象单元大小返回光标所在行数点击查找和引用返回光标选择区域的行数和列数点击查找和引用工作表中包含数据的最大行数点击查找和引用返回A列数据的最大行数点击查找和引用将所选区域文本插入新建文本框点击对象批量插入地址批注点击批注批量插入统一批注点击批注以A1单元内容批量插入批注点击批注以A1单元文本作表名插入工作表点击单元赋值批量插入当前文件名和表名及地址点击单元赋值区域录入当前单元地址点击单元赋值区域录入当前日期点击单元赋值区域录入当前数字日期点击单元赋值区域录入当前日期和时间点击单元赋值不连续区域录入对勾点击单元赋值不连续区域录入当前文件名点击单元赋值不连续区域添加文本点击单元赋值不连续区域插入文本点击单元赋值从指定位置向下同时录入多单元指定内容点击单元赋值按aa工作表A列的内容排列工作表标签顺序点击工作表删除全部未选定工作表点击工作表工作表标签排序点击工作表在目录表建立本工作簿中各表链接目录点击文件管理建立工作表文本目录点击工作表查另一文件的全部表名点击工作表点击单元赋值当前单元录入计算机用户名点击单元赋值解除全部工作表保护点击工作表为指定工作表加指定密码保护表点击密码在有密码的工作表执行代码点击密码执行前需要验证密码的宏(控件按钮代码)点击密码拷贝A1公式和格式到A2点击单元赋值复制单元数值点击单元赋值插入数值条件格式点击格式插入透明批注点击批注单元赋值定位定位定位定位定位定位点击单元赋值当前单元加2点击单元赋值A列等于A列减B列点击单元赋值用于光标选定多区域跳转指定单元(工作表代码)点击定位单元赋值单元赋值单元赋值单元赋值单元赋值单元赋值事件事件事件其他其他定位打印单元赋值对象事件其他信息事件单元赋值点击事件指定允许编辑区域点击编辑解除允许编辑区域限制点击编辑删除A列为指定内容的行点击行列操作删除A列非数字单元行点击行列操作有条件删除当前行点击行列操作选择下一行点击定位选择第5行开始所有数据行点击定位选择光标或选区所在行点击定位定位名称点击名称选择到指定列的最后行点击定位将Sheet1的A列的非空值写到Sheet2的A列点击单元赋值将名称1的数据写到名称2点击名称定位格式对象点击数据单元赋值名称点击工作表按A列数据批量修改表名称点击工作表按A列数据批量创建新表(控件按钮代码)点击工作表清除剪贴板点击其他其他文件管理文件管理文件管理文件管理文件管理文件管理文件管理文件管理文件管理文件管理点击文件管理将A列数据排序到D列点击单元赋值单元赋值定位行列操作点击数据取消数据有效限制点击数据重排窗口点击窗口定位定位定位工作表文件管理行列操作工作表工作表工作表格式工作表工作表点击工作表工作表行列操作定位点击定位格式格式事件事件数据其他其他单元赋值事件事件事件事件点击单元赋值选择2至4行点击定位在当前选区有条件替换数值为文本点击事件自动筛选全部显示指定列点击筛选自动筛选第2列值为A的行点击筛选取消自动筛选()点击筛选全部显示指定表的自动筛选点击筛选强行合并单元点击格式指定A列的日期格式点击格式单元赋值事件事件点击行列操作在A列产生不重复随机数点击单元赋值单元赋值单元赋值其他信息格式格式点击单元赋值建立当前工作表的副本为001表点击工作表插入新表点击工作表在第一个表前插入多工作表点击工作表单元赋值自定义函数信息超链接超链接超链接超链接查找和引用点击查找和引用查找和引用查找和引用查找和引用点击查找和引用返回A列非空单元数量点击查找和引用返回圆周率π点击其他打印单元赋值单元赋值单元赋值点击打印打开excel就执行某个宏点击事件信息事件点击工作表重算指定表点击工作表将第5行移到窗口的最上面点击窗口对第一张工作表的指定区域进行排序点击单元赋值显示指定工作表的打印预览点击打印用单元格A1的内容作为文件名另存当前工作簿点击文件管理[禁用/启用]保存和另存的代码点击文件管理在A和B列返回当前选区的名称和公式点击单元赋值朗读朗读A列,按ESC键中止点击语音朗读固定语句，请按ESC键终止点击语音在M和N列的14行以下选择单元时显示调用日历控件点击对象（工作表代码）添加自定义序列点击其他弹出打印对话框点击打印打印事件点击工作表把a列不重复值取到e列点击查找和引用查找和引用工作表点击事件事件其他点击其他按照当前行A列的图片名称插入图片到H列点击图片当前行下插入1行点击工作表取消指定行或列的隐藏点击工作表复制单元格所在行点击其他复制单元格所在列点击其他新建一个工作表点击工作表新建一个工作簿点击工作簿工作表工作簿点击工作簿录。
157个常用宏(有代码可直接复制)
奇偶页分别打印点击自动打印多工作表第一页点击查找A列文本循环插入分页符(模块）点击将A列最后数据行以上的所有B列图片大小调整为所在点击单元大小返回光标所在行数点击在A1返回当前选中单元格数量点击返回当前工作簿中工作表数量点击返回光标选择区域的行数和列数点击工作表中包含数据的最大行数点击返回A列数据的最大行数点击将所选区域文本插入新建文本框点击批量插入地址批注点击批量插入统一批注点击以A1单元内容批量插入批注点击不连续区域插入当前文件名和表名及地址点击不连续区域录入当前单元地址点击连续区域录入当前单元地址点击返回当前单元地址点击不连续区域录入当前日期点击不连续区域录入当前数字日期点击不连续区域录入当前日期和时间点击不连续区域录入对勾点击不连续区域录入当前文件名点击不连续区域添加文本点击点击当前单元录入计算机用户名点击为指定工作表加指定密码保护表点击在有密码的工作表执行代码点击执行前需要验证密码的宏(控件按钮代码)点击拷贝A1公式和格式到A2点击插入数值条件格式点击点击当前单元加2点击A列等于A列减B列点击点击每编辑一个单元保存文件点击指定允许编辑区域点击解除允许编辑区域限制点击删除A列为指定内容的行点击删除A列非数字单元行点击有条件删除当前行点击选择第5行开始所有数据行点击选择光标或选区所在行点击选择到指定列的最后行点击将Sheet1的A列的非空值写到Sheet2的A列点击将全部工作表名称写到A列点击按A列数据批量创建新表(控件按钮代码)点击判断指定文件是否已经打开点击点击将指定范围的数据排列到D列点击光标移动点击光标所在行上移一行点击点击打开文件时提示指定工作表是保护状态点击(ThisWorkbook)全选固定范围内小于0的单元点击全选选定范围内小于0的单元点击固定区域单元分类变色点击点击显示光标所在单元的批注的代码点击提示确定或取消执行宏点击拷贝指定表不相邻多列数据到新位置点击在当前选区有条件替换数值为文本点击自动筛选第2列值为A的行点击取消自动筛选()点击全部显示指定表的自动筛选点击点击在A列产生不重复随机数点击将A列数据随机排列到F列点击取消选定区域的公式只保留值(假空转真空)点击填公式点击在第一个表前插入多工作表点击点击返回表中第一个非空单元地址(行搜索)点击返回表中各非空单元区域地址(行搜索)点击返回第一个数值行号点击返回第1行最右边非空单元的列号点击返回连续数值单元的数量点击统计指定范围和内容的单元数量点击统计不同颜色的数字的和（自定义函数）点击返回圆周率π点击定义指定单元内容为页眉/页脚点击提示并全部清除当前选择区域点击对指定工作表执行取消隐藏》打印》隐藏工作表点击弹出提示A1单元内容点击撤消工作表保护并取消密码点击将第5行移到窗口的最上面点击对第一张工作表的指定区域进行排序点击显示指定工作表的打印预览点击用单元格A1的内容作为文件名另存当前工作簿点击添加自定义序列点击弹出打印对话框点击点击把a列不重复值取到e列点击当前选区的行列数点击返回光标所在行号点击VBA返回公式结果点击合并A1至C1的内容写到D15单元的批注中点击重算模式点击分离字符串到每个单元格点击条件格式点击自动录入一个符号点击保护所有工作表点击判断正负数点击判断奇偶数点击选中变色点击自动输入当前日期点击高亮显示当前行点击按A列数据批量修改表名称点击光标指定到名称指定位置（模块）点击删除指定列含空格的所有行点击删除指定列所有重复行点击。
Excel宏大全
End Sub
Private Sub CommandButton1_Click()
重排窗口
End Sub
当前单元返回按钮名称（控件按钮代码）
Private Sub CommandButton1_Click()
ActiveCell = CommandButton1.Caption
Call 保护工作表
.Caption = “取消工作表保护”
Exit Sub
End If
If .Caption = “取消工作表保护” Then
Call 取消工作表保护
.Caption = “保护工作表”
If .Caption = “宏1″ Then
Call 宏1
.Caption = “宏2″
Exit Sub
End If
If .Caption = “宏2″ Then
Call 宏2
.Caption = “宏3″
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range(“A1″) > 2 Then
CommandButton1.Visible = 1
Else
CommandButton1.Visible = 0
.Activate
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
End Sub
Sub 取消原分页()
Cells.Select
ActiveSheet.ResetAllPageBreaks
Excel办公用宏大全
宏文件集▲打开全部隐藏工作表返回Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = TrueNext iEnd Sub▲循环宏返回Sub 循环()AAA = Range("C2")Dim i As LongDim times As Longtimes = AAA'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range("完成标志") = "完成" Then Exit For '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则 'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For '如果某列出现"完成"内容则退出循环Next iEnd Sub▲录制宏时调用“停止录制”工具栏返回Sub 录制宏时调用停止录制工具栏()mandBars("Stop Recording").Visible = TrueEnd Sub▲高级筛选5列不重复数据至指定表返回Sub 高级筛选5列不重复数据至Sheet2()Sheets("Sheet2").Range("A1:E65536") = "" '清除Sheet2的A:D列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _"A1"), Unique:=TrueSheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub▲双击单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$4"Call 宏1Cancel = TrueCase "$B$4"Call 宏2Cancel = TrueCase "$C$4"Call 宏3Cancel = TrueCase "$E$4"Call 宏4Cancel = TrueEnd SelectEnd Sub▲双击指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then Call 打开隐藏表End Sub▲进入单元执行宏(工作表代码)返回'以单元格进入代替按钮对象调用宏If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$5" '单元地址(Target.Address),或命名单元名字()Call 宏1Case "$B$5"Call 宏2Case "$C$5"Call 宏3End SelectEnd Sub▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call 打开隐藏表End Sub▲在多个宏中依次循环执行一个（控件按钮代码）返回Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub▲在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()With CommandButton1If .Caption = "保护工作表" ThenCall 保护工作表.Caption = "取消工作表保护"Exit SubEnd IfIf .Caption = "取消工作表保护" ThenCall 取消工作表保护.Caption = "保护工作表"Exit SubEnd IfEnd WithEnd Sub▲在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = "宏1" ThenCall 宏1.Caption = "宏2"Exit SubEnd IfIf .Caption = "宏2" ThenCall 宏2.Caption = "宏3"Exit SubEnd IfIf .Caption = "宏3" ThenCall 宏3.Caption = "宏1"End IfEnd WithEnd Sub▲根据A1单元文本隐藏/显示按钮（控件按钮代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("A1") > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub▲当前单元返回按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub▲当前单元内容返回到按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub▲奇偶页分别打印返回Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数MsgBox "现在打印奇数页,按确定开始."ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox "现在打印偶数页,按确定开始."For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub▲自动打印多工作表第一页返回Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx = InputBox("请输入起始工作表名字:")sy = InputBox("请输入结束工作表名字:")y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub▲查找A列文本循环插入分页符返回Sub 循环插入分页符()' Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页")'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)Call 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _ .ActivateActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub▲将A列最后数据行以上的所有B列图片大小调整为所在单元大小返回Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing Then Pic.Top = Pic.TopLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub▲返回光标所在行数返回Sub 返回光标所在行数()x = ActiveCell.RowEnd Sub▲在A1返回当前选中单元格数量返回Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub▲返回当前工作簿中工作表数量返回Sub 返回当前工作簿中工作表数量()t = Application.Sheets.CountMsgBox tEnd Sub▲返回光标选择区域的行数和列数返回Sub 返回光标选择区域的行数和列数()x = Selection.Rows.County = Selection.Columns.CountRange("A1") = xRange("A2") = yEnd Sub▲工作表中包含数据的最大行数返回Sub 包含数据的最大行数()n = Cells.Find("*", , , , 1, 2).RowMsgBox nEnd Sub▲返回A列数据的最大行数返回Sub 返回A列数据的最大行数()n = Range("a65536").End(xlUp).RowRange("B1") = nEnd SubSub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + ActiveCell.Selection.Characters.Text = "问题：" & nWith Selection.Characters(Start:=1, Length:=3).Font.Name = "黑体".FontStyle = "常规".Size = 12End WithEnd Sub▲批量插入地址批注返回Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionment.Deleter.AddCommentment.Visible = Falsement.Text Text:="本单元格：" & r.Address & " of " & Selection.AddressNextEnd IfEnd Sub▲批量插入统一批注返回Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")If Selection.Cells.Count > 0 ThenFor Each r In Selectionment.Visible = Falsement.Text Text:=msgNextEnd IfEnd Sub▲以A1单元内容批量插入批注返回Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=[a1].TextNextEnd IfEnd Sub▲不连续区域插入当前文件名和表名及地址返回Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = "[" + + "]" + + "!" + mycell.Address NextEnd Sub▲不连续区域录入当前单元地址返回Sub 区域录入当前单元地址()For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub▲连续区域录入当前单元地址返回Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub▲返回当前单元地址返回Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub▲不连续区域录入当前日期返回Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")End Sub▲不连续区域录入当前数字日期返回Sub 区域录入当前数字日期()Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")End Sub▲不连续区域录入当前日期和时间返回Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")End Sub▲不连续区域录入对勾返回Sub 批量录入对勾()Selection.FormulaR1C1 = "√"End Sub▲不连续区域录入当前文件名返回Sub 批量录入当前文件名()Selection.FormulaR1C1 = End Sub▲不连续区域添加文本返回Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & "文本内容"NextEnd Sub▲不连续区域插入文本返回Sub 批量插入文本()Dim s As RangeFor Each s In Selections = "文本内容" & sNextEnd Sub▲从指定位置向下同时录入多单元指定内容返回Sub 从指定位置向下同时录入多单元指定内容()Dim arrarr = Array("1", "2", "13", "25", "46", "12", "0", "20")[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub▲按aa工作表A列的内容排列工作表标签顺序返回Sub 按aa工作表A列的内容排列工作表标签顺序()Dim I%, str1$I = 1Sheets("aa").SelectDo While Cells(I, 1).Value <> ""str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets("aa").SelectLoopEnd Sub▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add = nmEnd Sub▲删除全部未选定工作表返回Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As BooleanDim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n - 1If ShtName(i) = TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub▲工作表标签排序返回Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox("工作表按升序排列请选 '是[Y]'. " & vbCrLf & vbCrLf & "工作表按降序排列请选 '否[N]'", vbYesNoCancel, "工作表排序") If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then 'Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse 'Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub▲定义指定工作表标签颜色返回Sub 定义指定工作表标签颜色()Sheets("Sheet1").Tab.ColorIndex = 46End Sub▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets("目录").ActivateIf Err = 0 ThenSheets("目录").UsedRange.DeleteElseSheets.Add = "目录"End IfFor i = 1 To Sheets.CountIf Sheets(i).Name <> "目录" Thens = s + 1Set Rng = Sheets("目录").Cells(((s - 1) Mod 20) + 1, (s - 1) \ 20 + 1 + 1)Rng = Format(s, " 0") & ". " & Sheets(i).NameActiveSheet.Hyperlinks.Add Rng, "#" & Sheets(i).Name & "!A1", ScreenTip:=Sheets(i).Name End IfNextSheets("目录").Range("b:iv").EntireColumn.ColumnWidth = 20End Sub▲建立工作表文本目录返回Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)Sheets(1).Name = "目录"For i = 2 To Sheets.CountCells(i - 1, 1) = Sheets(i).Name'Sheets(1).Hyperlinks.Add Cells(i - 1, 1), "#" & Sheets(i).Name & "!A1" '添加超链接NextEnd Sub▲查另一文件的全部表名返回Sub 查另一文件的全部表名()On Error Resume NextDim i%Dim sh As WorksheetApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=ThisWorkbook.Path & "\2.xls"Windows("1.xls").Activate '当前文件名称Sheets("Sheet1").Select '当前表名称i = 1 '将表名称返回到第1行For Each sh In Workbooks("2.xls").WorksheetsCells(i, 1) = '将表名称返回到第1列i = i + 1 '返回每个表名称向下移动1行Next shWindows("2.xls").Close '关闭对象文件Application.ScreenUpdating = TrueEnd Sub▲当前单元录入计算机名返回Sub 当前单元录入计算机名()Selection = Environ("COMPUTERNAME")'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲当前单元录入计算机用户名返回 Sub 当前单元录入计算机用户名()Selection = Environ("Username")'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲解除全部工作表保护返回Sub 解除全部工作表保护()Dim n As IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext nEnd Sub▲为指定工作表加指定密码保护表返回Sub 为指定工作表加指定密码保护表()Sheet10.Protect Password:="123"End Sub▲在有密码的工作表执行代码返回Sub 在有密码的工作表执行代码()Sheets("1").Unprotect Password:=123 '假定表名为“1”，密码为“123” 打开工作表Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True '隐藏C列空值行Sheets("1").Protect Password:=123 '重新用密码保护工作表End Sub▲执行前需要验证密码的宏(控件按钮代码)返回Private Sub CommandButton1_Click()If InputBox("请输入密码：") <> "123" Then '密码是123MsgBox "密码错误,按确定退出!", 64, "提示"Exit SubEnd IfCells(1, 1) = 10End SubSub 执行前需要验证密码的宏()If InputBox("请输入您的使用权限:", "系统提示") = 123 Then重排窗口 '要执行的宏代码或宏名称ElseMsgBox "对不起,您没有使用该宏的权限,按确定键后退出!"End IfEnd Sub▲拷贝A1公式和格式到A2返回Sub 拷贝A1公式到A2()Workbooks("临时表").Sheets("表1").Range("A1").CopyWorkbooks("临时表").Sheets("表2").Range("A2").PasteSpecialEnd Sub▲复制单元数值返回Sub 复制数值()s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2")Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = sEnd Sub▲插入数值条件格式返回Sub 插入数值条件格式()Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="70"Selection.FormatConditions(1).Interior.ColorIndex = 45Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _Formula1:="55"Selection.FormatConditions(2).Interior.ColorIndex = 39Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="60"Selection.FormatConditions(3).Interior.ColorIndex = 34End Sub▲插入透明批注返回Sub 插入透明批注()Selection.AddCommentment.Visible = FalseDim XS As WorksheetFor i = 1 To ments.Countments(i).Text "透明批注"ments(i).Shape.Fill.Visible = msoFalseNextEnd Sub▲添加文本返回Sub 添加文本()Selection = Selection + "×" '不可在数字后添加文本'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲光标定位到指定工作表A列最后数据行下一单元返回Sub 光标定位到指定工作表A列最后数据行下一单元()a = Sheets("数据库").[a65536].End(xlUp).RowSheets("数据库").SelectRange("A" & a + 1).SelectEnd Sub▲定位选定单元格式相同的全部单元格返回Sub 定位选定单元格式相同的全部单元格()Dim FirstCell As Range, FoundCell As RangeDim AllCells As RangeWith Application.FindFormat.Clear.NumberFormatLocal = Selection.NumberFormatLocal.HorizontalAlignment = Selection.HorizontalAlignment.VerticalAlignment = Selection.VerticalAlignment.WrapText = Selection.WrapText.Orientation = Selection.Orientation.AddIndent = Selection.AddIndent.IndentLevel = Selection.IndentLevel.ShrinkToFit = Selection.ShrinkToFit.MergeCells = Selection.MergeCells = .Font.FontStyle = Selection.Font.FontStyle.Font.Size = Selection.Font.Size.Font.Strikethrough = Selection.Font.Strikethrough.Font.Subscript = Selection.Font.Subscript.Font.Underline = Selection.Font.Underline.Font.ColorIndex = Selection.Font.ColorIndex.Interior.ColorIndex = Selection.Interior.ColorIndex.Interior.Pattern = Selection.Interior.Pattern.Locked = Selection.Locked.FormulaHidden = Selection.FormulaHiddenEnd WithSet FirstCell = edRange.Find(what:="", searchformat:=True)If FirstCell Is Nothing ThenExit SubEnd IfSet AllCells = FirstCellSet FoundCell = FirstCellDoSet FoundCell = edRange.Find(After:=FoundCell, what:="", searchformat:=True) If FoundCell Is Nothing Then Exit DoSet AllCells = Union(FoundCell, AllCells)If FoundCell.Address = FirstCell.Address Then Exit DoLoopAllCells.SelectEnd Sub▲按当前单元文本定位返回Sub 按当前单元文本定位()ABC = SelectionDim aa As RangeFor Each a In edRangeIf a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲按固定文本定位返回Sub 文本定位()Dim aa As RangeFor Each a In edRangeIf a Like "*合计*" ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲删除包含固定文本单元的行或列返回Sub 删除包含固定文本单元的行或列()DoCells.Find(what:="哈哈").ActivateSelection.EntireRow.Delete '删除行' Selection.EntireColumn.Delete '删除列Loop Until Cells.Find(what:="哈哈") Is NothingEnd Sub▲定位数据及区域以上的空值返回Sub 定位数据及区域以上的空值()Dim aa As RangeFor Each a In edRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲右侧单元自动加5(工作表代码)返回Private Sub Worksheet_Change(ByVal Target As Range)Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd Sub▲当前单元加2返回Sub 当前单元加2()Selection = Selection + 2'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲A列等于A列减B列返回Sub A列等于A列减B列()For i = 1 To 23Cells(i, 1) = Cells(i, 1) - Cells(i, 2)NextEnd Sub▲用于光标选定多区域跳转指定单元(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal T As Range)a = Array([b6:b7], [e6], [h6])For i = 0 To 2If Not Application.Intersect(T, a(i)) Is Nothing Then[a1].Select: Exit ForEnd IfNextEnd Sub▲将A1单元录入的数据累加到B1单元（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)Dim t As LongIf Target.Address = "$A$1" Thent = Sheet1.Range("$B$1").ValueSheet1.Range("$B$1").Value = t + Target.ValueEnd IfEnd Sub▲在指定颜色区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> "√", "√", "")NextEnd Sub▲在指定区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target, Range("D6:D20")) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = "" Then.Value = "√"Else.Value = ""End IfEnd WithNextEnd IfEnd IfEnd Sub▲双击指定单元，循环录入文本（工作表代码）返回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双击指定单元，循环录入文本（工作表代码）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▲单元区域引用（工作表代码）返回Private Sub Worksheet_Activate()Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").ValueEnd Sub▲在指定区域选择单元时数值加1（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect([a1:e10], Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub▲混合文本的编号返回Sub 混合文本的编号()Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3, 100)) + 1) End Sub▲指定区域单元双击数据累加（工作表代码）返回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▲选择单元区域触发事件（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = "$A$1:$B$2" ThenMsgBox "你选择了$A$1:$B$2单元"End IfEnd Sub▲当修改指定单元内容时自动执行宏（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then重排窗口End IfEnd Sub▲被指定单元内容限制执行宏返回Sub 被指定单元限制执行宏()If Range("$A$1") = "关闭" Then Exit Sub窗口End Sub▲双击单元隐藏该行（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Rows(Target.Row).Hidden = TrueEnd Sub▲高亮显示行（工作表代码）返回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▲高亮显示行和列（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34Columns(Target.Column).Interior.ColorIndex = 34End Sub▲为指定工作表设置滚动范围（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Sheet1.ScrollArea = "A1:M30"End Sub▲在指定单元记录打印和预览次数（工作簿代码）返回Private Sub Workbook_BeforePrint(Cancel As Boolean)Range("A1") = 1 + Range("A1")End Sub▲自动数字金额转大写（工作表代码）返回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 * 100f = (j / 10 - Int(j / 10)) * 10A = 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▲将全部工作表的A1单元作为单击按钮（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)If Target.Address = "$A$1" ThenCall 宏名End IfEnd Sub▲闹钟——到指定时间执行宏（工作簿代码）返回Private Sub Workbook_Open()Application.OnTime ("11:45:00"), "提示1" '宏名字Application.OnTime ("12:00:00"), "提示2" '宏名字End Sub▲改变Excel界面标题的宏（工作簿代码）返回Private Sub Workbook_Open()Application.Caption = "春节快乐"End Sub▲在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Worksheets("表2").Range("A1") = Target.Address(0, 0)End Sub▲B列录入数据时在A列返回记录时间（工作表代码）返回Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub▲当指定区域修改时在其右侧的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▲指定单元显示光标位置内容（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal T As Range)Sheets(1).Range("A1") = SelectionEnd Sub▲每编辑一个单元保存文件返回Private Sub Worksheet_Change(ByVal Target As Range)ThisWorkbook.SaveEnd Sub▲指定允许编辑区域返回Sub 指定允许编辑区域()ActiveSheet.ScrollArea = "B8:G15"End Sub▲解除允许编辑区域限制返回Sub 解除允许编辑区域限制()ActiveSheet.ScrollArea = ""End Sub▲删除指定行返回Sub 删除指定行()Workbooks("临时表").Sheets("表2").Range("5:5").DeleteEnd Sub▲删除A列为指定内容的行返回Sub 删除A列为指定内容的行()Dim a, b As Integera = Sheet1.[a65536].End(xlUp).RowFor b = a To 2 Step -1If Cells(b, 1).Value = "删除" ThenRows(b).DeleteEnd IfNextEnd Sub▲删除A列非数字单元行返回Sub 删除A列非数字单元行()i = [a65536].End(xlUp).RowRange("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.DeleteEnd Sub▲有条件删除当前行返回Sub 有条件删除当前行()If [A1] = 2 Or [B1] = "删除" ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub▲选择下一行返回Sub 选择下一行()ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.SelectEnd Sub▲选择第5行开始所有数据行返回Sub 选择第5行开始所有数据行A()Dim i%i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).EntireRow.RowRows("5:" & i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows("5:" & Cells.Find("*", , , , 1, 2).Row).SelectEnd Sub▲选择光标或选区所在行返回Sub 选择光标或选区所在行()Selection.EntireRow.SelectEnd Sub▲选择光标或选区所在列返回Sub 选择光标或选区所在列()Selection.EntireColumn.SelectEnd Sub▲光标定位到名称指定位置返回Sub 定位()Application.Goto Range(Evaluate("名称"))End Sub▲选择名称定义的数据区返回Sub 选择名称定义的数据区()[数据区].Select '插入名称要使用INDIRECT函数'Range("数据区").Select 或者'Sheet1.Range("数据区").Select 或者End Sub▲选择到指定列的最后行返回Sub 选择到指定列的最后行()Range("C4:G" & [G65536].End(xlUp).Row).SelectEnd Sub▲将Sheet1的A列的非空值写到Sheet2的A列返回Sub 将Sheet1的A列的非空值写到Sheet2的A列()Sheet1.Columns("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1]End Sub▲将名称1的数据写到名称2返回Sub Macro2()Range("位置2") = Range("位置1").ValueEnd Sub▲单元反选返回Sub 单元反选()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress As String, taddress As Stringraddress = Selection.Addresstaddress = edRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = "=0"raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address.DeleteEnd WithActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub▲调整选中对象中的文字返回Sub 调整选中对象中的文字()'文字居中、自动调整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd WithEnd Sub▲去除指定范围内的对象返回Sub 去除指定范围内的对象()Dim p As ShapeSet My = Worksheets("工作表名")For Each p In My.ShapesIf Not Application.Intersect(p.TopLeftCell, Range("范围")) Is Nothing Then p.Delete NextEnd Sub▲更新透视表数据项返回Sub DeleteMissingItems2002All()'防止数据透视表中显示无用的数据项'在 Excel 2002 或更高版本中'如果无用的数据项已经存在,'运行这个宏可以更新Dim pt As PivotTableDim ws As WorksheetFor Each ws In ActiveWorkbook.WorksheetsFor Each pt In ws.PivotTablespt.PivotCache.MissingItemsLimit = xlMissingItemsNoneNext ptNext wsEnd Sub▲将全部工作表名称写到A列返回Sub 将全部表名称写到A列()k = 1For Each Sht In SheetsCells(k + 1, 1) = '指定写入的行和列。
EXCEL 常用的宏代码大全
EXCEL 常用的宏代码大全本示例为设置密码窗口(1)If Application.InputBox("请输入密码：") = 1234 Then[A1] = 1 '密码正确时执行Else: MsgBox "密码错误，即将退出！" '此行与第2行共同设置密码End If本示例为设置密码窗口(1)X = MsgBox("是否真的要结帐？", vbYesNo)If X = vbYes ThenClose本示例为设置工作表密码ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码ActiveSheet.Unprotect Password:=641112 '撤消工作表保护并取消密码'本示例关闭除正在运行本示例的工作簿以外的其他所有工作簿，并保存其更改内容。
For Each w In WorkbooksIf <> Thenw.Close SaveChanges:=TrueEnd IfNext w'每次打开工作簿时，本示例都最大化Microsoft Excel 窗口。
Application.WindowState = xlMaximized'本示例显示活动工作表的名称。
MsgBox "The name of the active sheet is " & '本示例保存当前活动工作簿的副本。
ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS"'下述过程激活工作簿中的第四张工作表。
Sheets(4).Activate'下述过程激活工作簿中的第1张工作表。
Worksheets(1).Activate'本示例通过将Saved 属性设为True 来关闭包含本段代码的工作簿，并放弃对该工作簿的任何更改。
Excel宏大全
Excel宏大全EXCEL 宏命令大全 ?打开全部隐藏工作表Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.Count Sheets(i).Visible = TrueNext iEnd Sub循环宏Sub 循环()AAA = Range(“C2″)Dim i As LongDim times As Longtimes = AAA‘times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range(“完成标志”) = “完成” Then Exit For ‘如果名为’完成标志’的命名单元的值等于’完成’,则退出循环,如果一开始就等于’完成’,则只执行一次循环就退出‘If Sheets(“传送参数”).Range(“A” & i).Text = “完成” Then Exit For ’如果某列出现”完成”内容则退出循环Next iEnd Sub录制宏时调用“停止录制”工具栏Sub 录制宏时调用停止录制工具栏()/doc/b0c8331752d380eb62946da2.ht mlmandBars(“Stop Recording”).Visible = TrueEnd Sub高级筛选5列不重复数据至指定表Sub 高级筛选5列不重复数据至Sheet2()Sheets(“Sheet2″).Range(“A1:E65536″) = “” ‘清除Sheet2的A:D列Range(“A1:E65536″).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _“A1″), Unique:=TrueSheet2.Columns(“A:E”).Sort Key1:=Sheet2.Range(“A2″), Order1:=xlAscending, Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub双击单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range(“$A$1″) = “关闭” Then Exit SubSelect Case Target.AddressCase “$A$4″Call 宏1Cancel = TrueCase “$B$4″Call 宏2Cancel = TrueCase “$C$4″Call 宏3Cancel = TrueCase “$E$4″Call 宏4Cancel = TrueEnd SelectEnd Sub双击指定区域单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range(“$A$1″) = “关闭” Then Exit SubIf Not Application.Intersect(Target, Range(“A4:A9″, “C4:C9″)) Is Nothing Then Call 打开隐藏表End Sub进入单元执行宏(工作表代码)Private Sub Worksheet_SelectionChange(ByVal Target As Range)‘以单元格进入代替按钮对象调用宏If Range(“$A$1″) = “关闭” Then Exit SubSelect Case Target.AddressCase “$A$5″ ‘单元地址(Target.Address),或命名单元名字(/doc/b0c8331752d380eb62946da2.html)Call 宏1Case “$B$5″Call 宏2Case “$C$5″Call 宏3End SelectEnd Sub进入指定区域单元执行宏(工作表代码)Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range(“$A$1″) = “关闭” Then Exit SubIf Not Application.Intersect(Target, Range(“A4:A9″,”C4:C9″)) Is Nothing Then Call 打开隐藏表End Sub在多个宏中依次循环执行一个（控件按钮代码）Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Private Sub CommandButton1_Click()With CommandButton1If .Caption = “保护工作表” ThenCall 保护工作表.Caption = “取消工作表保护”Exit SubEnd IfIf .Caption = “取消工作表保护” ThenCall 取消工作表保护.Caption = “保护工作表”Exit SubEnd IfEnd WithEnd Sub在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = “宏1″ Then Call 宏1.Caption = “宏2″Exit SubEnd IfIf .Caption = “宏2″ Then Call 宏2.Caption = “宏3″Exit SubEnd IfIf .Caption = “宏3″ Then Call 宏3.Caption = “宏1″Exit SubEnd IfEnd WithEnd Sub根据A1单元文本隐藏/显示按钮（控件按钮代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range(“A1″) > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub当前单元返回按钮名称（控件按钮代码）Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub当前单元内容返回到按钮名称（控件按钮代码）Private Sub CommandButton1_Click() CommandButton1.Caption = ActiveCellEnd Sub奇偶页分别打印Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro(“GET.DOCUMENT(50)”) ‘总页数MsgBox “现在打印奇数页,按确定开始.”For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox “现在打印偶数页,按确定开始.”For i = 2 To Ps Step 2 ActiveSheet.PrintOut from:=i, To:=i Next iEnd Sub自动打印多工作表第一页Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx = InputBox(“请输入起始工作表名字:”) sy = InputBox(“请输入结束工作表名字:”) y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub查找A列文本循环插入分页符Sub 循环插入分页符()‘ Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range(“a:a”), “分页”)‘times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:=”分页”, After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.AddBefore:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub将A列最后数据行以上的所有B列图片大小调整为所在单元大小Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range(“B1:B” & i)) Is Nothing ThenPic.Top = Pic.T opLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub返回光标所在行数Sub 返回光标所在行数()x = ActiveCell.RowRange(“A1″) = xEnd Sub在A1返回当前选中单元格数量Sub 在A1返回当前选中单元格数量() [A1] = Selection.CountEnd Sub返回当前工作簿中工作表数量Sub 返回当前工作簿中工作表数量() t = Application.Sheets.Count MsgBox tEnd Sub返回光标选择区域的行数和列数Sub 返回光标选择区域的行数和列数() x = Selection.Rows.County = Selection.Columns.Count Range(“A1″) = xRange(“A2″) = yEnd Sub工作表中包含数据的最大行数Sub 包含数据的最大行数()n = Cells.Find(“*”, , , , 1, 2).Row MsgBox nEnd Sub返回A列数据的最大行数Sub 返回A列数据的最大行数()n = Range(“a65536″).End(xlUp).Row Range(“B1″) = nEnd Sub将所选区域文本插入新建文本框Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizon tal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = “问题：” & nWith Selection.Characters(Start:=1, Length:=3).Font.Name = “黑体”.FontStyle = “常规”.Size = 12End WithEnd Sub批量插入地址批注Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selection/doc/b0c8331752d380eb62946da2.ht mlment.Deleter.AddComment/doc/b0c8331752d380eb62946da2.ht mlment.Visible = False/doc/b0c8331752d380eb62946da2.ht mlment.Text Text:=”本单元格：” & r.Address & ” of ” & Selection.AddressNextEnd IfEnd Sub批量插入统一批注Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox(“请输入欲批量插入的批注”, “提示”, “随便输点什么吧”)If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddComment/doc/b0c8331752d380eb62946da2.ht mlment.Visible = False/doc/b0c8331752d380eb62946da2.ht mlment.Text Text:=msgNextEnd IfEnd Sub以A1单元内容批量插入批注Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddComment/doc/b0c8331752d380eb62946da2.ht mlment.Visible = False/doc/b0c8331752d380eb62946da2.ht mlment.Text Text:=[a1].TextNextEnd IfEnd Sub不连续区域插入当前文件名和表名及地址Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = “[" + /doc/b0c8331752d380eb62946da2.html +"]” + /doc/b0c8331752d380eb62946da2.html + “!” + mycell.AddressNextEnd Sub不连续区域录入当前单元地址Sub 区域录入当前单元地址()For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub连续区域录入当前单元地址Sub 连续区域录入当前单元地址()Selection = “=ADDRESS(ROW(),COLUMN(),4,1)”Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub返回当前单元地址Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub不连续区域录入当前日期Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), “yyyy-m-d”) End Sub不连续区域录入当前数字日期Sub 区域录入当前数字日期()Selection.FormulaR1C1 = Format(Now(), “yyyymmdd”) End Sub不连续区域录入当前日期和时间Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), “yyyy-m-d h:mm:ss”)End Sub不连续区域录入对勾Sub 批量录入对勾()Selection.FormulaR1C1 = “√”End Sub不连续区域录入当前文件名Sub 批量录入当前文件名()Selection.FormulaR1C1 = /doc/b0c8331752d380eb62946da2.htmlEnd Sub不连续区域添加文本Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & “文本内容”NextEnd Sub不连续区域插入文本Sub 批量插入文本()Dim s As RangeFor Each s In Selections = “文本内容” & sNextEnd Sub从指定位置向下同时录入多单元指定内容Sub 从指定位置向下同时录入多单元指定内容() Dim arrarr = Array(“1″, “2″, “13″, “25″, “46″, “12″, “0″, “20″)[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub按aa工作表A列的内容排列工作表标签顺序Sub 按aa工作表A列的内容排列工作表标签顺序()Dim I%, str1$I = 1Sheets(“aa”).SelectDo While Cells(I, 1).Value <> “”str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets(“aa”).SelectLoopEnd Sub以A1单元文本作表名插入工作表Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add/doc/b0c8331752d380eb62946da2.ht ml = nmEnd Sub删除全部未选定工作表Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As BooleanDim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = /doc/b0c8331752d380eb62946da2.htmln = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n – 1If ShtName(i) = /doc/b0c8331752d380eb62946da2.html TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub工作表标签排序Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox(“工作表按升序排列请选‘是[Y]‘. ” & vbCrLf & vbCrLf & “工作表按降序排列请选‘否[N]‘”, vbYesNoCancel, “工作表排序”)If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then ‘Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then Sheets(j).Move Before:=Sheets(i)End IfNext jNext iElse ‘Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) Then Sheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub定义指定工作表标签颜色Sub 定义指定工作表标签颜色()Sheets(“Sheet1″).Tab.ColorIndex = 46End Sub在目录表建立本工作簿中各表链接目录Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets(“目录”).ActivateIf Err = 0 ThenSheets(“目录”).UsedRange.DeleteElseSheets.Add/doc/b0c8331752d380eb62946da2.ht ml = “目录”End IfFor i = 1 To Sheets.CountIf S heets(i).Name <> “目录” Thens = s + 1Set Rng = Sheets(“目录”).Cells(((s – 1) Mod20) + 1, (s – 1) \ 20 + 1 + 1)Rng = Format(s, ” 0″) & “. ” & Sheets(i).NameActiveSheet.Hyperlinks.Add Rng, “#” & Sheets(i).Name & “!A1″, ScreenTip:=Sheets(i).NameEnd IfNextSheets(“目录”).Range(“b:iv”).EntireColumn.ColumnWidth = 20End Sub建立工作表文本目录Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)Sheets(1).Name = “目录”For i = 2 To Sheets.CountCells(i – 1, 1) = Sheets(i).Name‘Sheets(1).Hyperlinks.Add Cells(i –1, 1), “#” & Sheets(i).Name & “!A1″ ‘添加超链接NextEnd Sub查另一文件的全部表名Sub 查另一文件的全部表名()On Error Resume NextDim i%Dim sh As WorksheetApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=ThisWorkbook.Path & “\2.xls”Windows(“1.xls“).Activate ‘当前文件名称Sheets(“Sheet1“).Select ‘当前表名称i = 1 ’将表名称返回到第1行For Each sh In Workbooks(“2.xls”).WorksheetsCells(i, 1) = /doc/b0c8331752d380eb62946da2.html ‘将表名称返回到第1列i = i + 1 ‘返回每个表名称向下移动1行Next shWindows(“2.xls”).Close ‘关闭对象文件Application.ScreenUpdating = TrueEnd Sub当前单元录入计算机名Sub 当前单元录入计算机名()Selection = Environ(“COMPUTERNAME”)‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End Sub当前单元录入计算机用户名Sub 当前单元录入计算机用户名()Selection = Environ(“Username”)‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End Sub解除全部工作表保护Sub 解除全部工作表保护()Dim n As IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext nEnd Sub为指定工作表加指定密码保护表Sub 为指定工作表加指定密码保护表()Sheet10.Protect Password:=”123″End Sub在有密码的工作表执行代码Sub 在有密码的工作表执行代码()Sheets(“1″).Unprotect Password:=123 ‘假定表名为“1”，密码为“123” 打开工作表Range(“C:C”).SpecialCells(xlCellTypeBlanks).EntireRow.Hid den = True ‘隐藏C列空值行Sheets(“1″).Protect Password:=123 ‘重新用密码保护工作表End Sub执行前需要验证密码的宏(控件按钮代码)Private Sub CommandButton1_Click()If InputBox(“请输入密码：”) <> “123″ Then ‘密码是123MsgBox “密码错误,按确定退出!”, 64, “提示”Exit SubEnd IfCells(1, 1) = 10End SubSub 执行前需要验证密码的宏()If InputBox(“请输入您的使用权限:”, “系统提示”) = 123 Then重排窗口‘要执行的宏代码或宏名称ElseMsgBox “对不起,您没有使用该宏的权限,按确定键后退出!”End IfEnd Sub拷贝A1公式和格式到A2Sub 拷贝A1公式到A2()Workbooks(“临时表”).Sheets(“表1″).Range(“A1″).CopyWorkbooks(“临时表”).Sheets(“表2″).Range(“A2″).PasteSpecialEnd Sub复制单元数值Sub 复制数值()s = Workbooks(“book1″).Sheets(“Sheet1″).Range(“A1:A2″)Workbooks(“book2″).Sheets(“Sheet1″).Range(“A1:A2″) = sEnd Sub插入数值条件格式Sub 插入数值条件格式()Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Form ula1:=”70″Selection.FormatConditions(1).Interior.ColorIndex = 45Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _Formula1:=”55″Selection.FormatConditions(2).Interior.ColorIndex = 39Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:=”60″Selection.FormatConditions(3).Interior.ColorIndex = 34End Sub插入透明批注Sub 插入透明批注()Selection.AddComment/doc/b0c8331752d380eb62946da2.ht mlment.Visible = FalseDim XS As WorksheetFor i = 1 To /doc/b0c8331752d380eb62946da2.htmlm ents.Count/doc/b0c8331752d380eb62946da2.ht mlments(i).Text “透明批注”/doc/b0c8331752d380eb62946da2.htmlments(i).Shape.Fill.Visible = msoFalseNextEnd Sub添加文本Sub 添加文本()Selection = Selection + “×” ‘不可在数字后添加文本‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End Sub光标定位到指定工作表A列最后数据行下一单元Sub 光标定位到指定工作表A列最后数据行下一单元()a = Sheets(“数据库”).[a65536].End(xlUp).RowSheets(“数据库”).SelectRange(“A” & a + 1).SelectEnd Sub定位选定单元格式相同的全部单元格Sub 定位选定单元格式相同的全部单元格()Dim FirstCell As Range, FoundCell As RangeDim AllCells As RangeWith Application.FindFormat.Clear.NumberFormatLocal = Selection.NumberFormatLocal.HorizontalAlignment = Selection.HorizontalAlignment.VerticalAlignment = Selection.VerticalAlignment.WrapText = Selection.WrapText.Orientation = Selection.Orientation.AddIndent = Selection.AddIndent.IndentLevel = Selection.IndentLevel.ShrinkT oFit = Selection.ShrinkT oFit.MergeCells = Selection.MergeCells/doc/b0c8331752d380eb62946da2.html = /doc/b0c8331752d380eb62946da2.html.Font.FontStyle = Selection.Font.FontStyle.Font.Size = Selection.Font.Size.Font.Strikethrough = Selection.Font.Strikethrough.Font.Subscript = Selection.Font.Subscript.Font.Underline = Selection.Font.Underline.Font.ColorIndex = Selection.Font.ColorIndex.Interior.ColorIndex = Selection.Interior.ColorIndex.Interior.Pattern = Selection.Interior.Pattern.Locked = Selection.Locked.FormulaHidden = Selection.FormulaHiddenEnd WithSet FirstCell = /doc/b0c8331752d380eb62946da2.htmle dRange.Find(what:=”", searchformat:=True)If FirstCell Is Nothing ThenExit SubEnd IfSet AllCells = FirstCellSet FoundCell = FirstCellDoSet FoundCell = /doc/b0c8331752d380eb62946da2.htmle dRange.Find(After:=FoundCell, what:=”", searchformat:=True)If FoundCell Is Nothing Then Exit DoSet AllCells = Union(FoundCell, AllCells)If FoundCell.Address = FirstCell.Address Then Exit DoLoopAllCells.SelectEnd Sub按当前单元文本定位Sub 按当前单元文本定位()ABC = SelectionDim aa As RangeFor Each a In /doc/b0c8331752d380eb62946da2.htmle dRangeIf a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub按固定文本定位Sub 文本定位()Dim aa As RangeFor Each a In /doc/b0c8331752d380eb62946da2.htmle dRangeIf a Like “*合计*” ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub删除包含固定文本单元的行或列Sub 删除包含固定文本单元的行或列()DoCells.Find(what:=”哈哈”).ActivateSelection.EntireRow.Delete ‘删除行‘ Selection.EntireColumn.Delete ‘删除列Loop Until Cells.Find(what:=”哈哈”) Is NothingEnd Sub定位数据及区域以上的空值Sub 定位数据及区域以上的空值()Dim aa As RangeFor Each a In /doc/b0c8331752d380eb62946da2.htmle dRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub右侧单元自动加5(工作表代码)Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd Sub当前单元加2Sub 当前单元加2()Selection = Selection + 2‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End SubA列等于A列减B列Sub A列等于A列减B列()For i = 1 To 23Cells(i, 1) = Cells(i, 1) – Cells(i, 2)NextEnd Sub用于光标选定多区域跳转指定单元(工作表代码)Private Sub Worksheet_SelectionChange(ByVal T As Range)a = Array([b6:b7], [e6], [h6])For i = 0 To 2If Not Application.Intersect(T, a(i)) Is Nothing Then[a1].Select: Exit ForEnd IfNextEnd Sub将A1单元录入的数据累加到B1单元（工作表代码）Private Sub Worksheet_Change(ByVal Target As Range)Dim t As LongIf Target.Address = “$A$1″ Thent = Sheet1.Range(“$B$1″).ValueSheet1.Range(“$B$1″).Value = t + T arget.ValueEnd IfEnd Sub在指定颜色区域选择单元时添加/取消”√”（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In T argetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> “√”, “√”, “”)NextEnd Sub在指定区域选择单元时添加/取消”√”（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target, Range(“D6:D20″)) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = “” Then。
_Exce宏大全(经典)
代码目录链接类别打开全部隐藏工作表点击循环宏点击录制宏时调用“停止录制”工具栏点击高级筛选5列不重复数据至指定表点击双击单元执行宏(工作表代码)点击双击指定区域单元执行宏(工作表代码)点击进入单元执行宏(工作表代码)点击进入指定区域单元执行宏(工作表代码)点击在多个宏中依次循环执行一个（控件按钮代码）点击在两个宏中依次循环执行一个并相应修改按钮名称点击（控件按钮代码）在三个宏中依次循环执行一个并相应修改按钮名称点击（控件按钮代码）根据A1单元文本隐藏/显示按钮（控件按钮代码）点击当前单元返回按钮名称（控件按钮代码）点击当前单元内容返回到按钮名称（控件按钮代码）点击奇偶页分别打印点击打印自动打印多工作表第一页点击打印查找A列文本循环插入分页符点击打印将A列最后数据行以上的所有B列图片大小调整为所在点击对象单元大小返回光标所在行数点击查找和引用在A1返回当前选中单元格数量点击查找和引用返回当前工作簿中工作表数量点击查找和引用返回光标选择区域的行数和列数点击查找和引用工作表中包含数据的最大行数点击查找和引用返回A列数据的最大行数点击查找和引用将所选区域文本插入新建文本框点击对象批量插入地址批注点击批注批量插入统一批注点击批注以A1单元内容批量插入批注点击批注不连续区域插入当前文件名和表名及地址点击单元赋值不连续区域录入当前单元地址点击单元赋值连续区域录入当前单元地址点击单元赋值返回当前单元地址点击单元赋值不连续区域录入当前日期点击单元赋值不连续区域录入当前数字日期点击单元赋值不连续区域录入当前日期和时间点击单元赋值不连续区域录入对勾点击单元赋值不连续区域录入当前文件名点击单元赋值不连续区域添加文本点击单元赋值不连续区域插入文本点击单元赋值从指定位置向下同时录入多单元指定内容点击单元赋值按aa工作表A列的内容排列工作表标签顺序点击工作表工作表工作表工作表工作表文件管理工作表工作表点击单元赋值当前单元录入计算机用户名点击单元赋值解除全部工作表保护点击工作表为指定工作表加指定密码保护表点击密码在有密码的工作表执行代码点击密码执行前需要验证密码的宏(控件按钮代码)点击密码拷贝A1公式和格式到A2点击单元赋值复制单元数值点击单元赋值插入数值条件格式点击格式插入透明批注点击批注单元赋值定位定位定位定位定位定位点击单元赋值当前单元加2点击单元赋值单元赋值定位单元赋值单元赋值单元赋值单元赋值单元赋值单元赋值单元赋值单元赋值事件事件事件事件其他其他定位打印单元赋值对象事件其他信息事件单元赋值单元赋值点击事件指定允许编辑区域点击编辑解除允许编辑区域限制点击编辑删除指定行点击行列操作删除A列为指定内容的行点击行列操作删除A列非数字单元行点击行列操作有条件删除当前行点击行列操作选择下一行点击定位选择第5行开始所有数据行点击定位选择光标或选区所在行点击定位定位名称点击名称选择到指定列的最后行点击定位将Sheet1的A列的非空值写到Sheet2的A列点击单元赋值将名称1的数据写到名称2点击名称定位格式对象点击数据单元赋值名称名称点击工作表按A列数据批量修改表名称点击工作表按A列数据批量创建新表(控件按钮代码)点击工作表清除剪贴板点击其他批量清除软回车点击其他判断指定文件是否已经打开点击事件当前文件另存到指定目录点击文件管理文件管理文件管理文件管理文件管理文件管理文件管理文件管理文件管理文件管理引用指定位置单元内容为部分文件名另存文件点击文件管理将A列数据排序到D列点击单元赋值将指定范围的数据排列到D列点击单元赋值定位行列操作点击数据取消数据有效限制点击数据重排窗口点击窗口按当前单元文本选择打开指定文件单元点击定位回车光标向右点击定位回车光标向下点击定位保护工作表时取消选定锁定单元点击工作表文件管理行列操作工作表工作表工作表工作表工作表格式工作表工作表点击工作表工作表行列操作定位点击定位固定区域单元分类变色点击格式格式事件事件数据点击其他显示光标所在单元的批注的代码点击其他单元赋值事件事件事件事件点击单元赋值选择2至4行点击定位在当前选区有条件替换数值为文本点击事件自动筛选全部显示指定列点击筛选自动筛选第2列值为A的行点击筛选取消自动筛选()点击筛选全部显示指定表的自动筛选点击筛选强行合并单元点击格式格式单元赋值事件事件点击行列操作在A列产生不重复随机数点击单元赋值单元赋值单元赋值点击其他返回指定单元的行高和列宽点击信息指定行高和列宽点击格式指定单元的行高和列宽与A1单元相同点击格式填公式点击单元赋值工作表工作表单元赋值自定义函数信息超链接超链接超链接超链接查找和引用点击查找和引用返回表中各非空单元区域地址(行搜索)点击查找和引用查找和引用查找和引用查找和引用查找和引用查找和引用点击查找和引用返回A列非空单元数量点击查找和引用返回圆周率π点击其他定义指定单元内容为页眉/页脚点击打印提示并全部清除当前选择区域点击单元赋值全部清除当前选择区域点击单元赋值清除指定区域数值点击单元赋值对指定工作表执行取消隐藏》打印》隐藏工作表点击打印打开文件时执行指定宏(工作簿代码)点击事件关闭文件时执行指定宏(工作簿代码)点击事件信息事件点击工作表重算指定表点击工作表将第5行移到窗口的最上面点击窗口对第一张工作表的指定区域进行排序点击单元赋值显示指定工作表的打印预览点击打印用单元格A1的内容作为文件名另存当前工作簿点击文件管理[禁用/启用]保存和另存的代码点击文件管理在A和B列返回当前选区的名称和公式点击单元赋值朗读朗读A列,按ESC键中止点击语音朗读固定语句，请按ESC键终止点击语音在M和N列的14行以下选择单元时显示调用日历控件点击对象（工作表代码）添加自定义序列点击其他弹出打印对话框点击打印打印事件事件点击工作表把a列不重复值取到e列点击查找和引用查找和引用工作表点击事件事件其他点击其他按照当前行A列的图片名称插入图片到H列点击图片当前行下插入1行点击工作表取消指定行或列的隐藏点击工作表复制单元格所在行点击其他复制单元格所在列点击其他新建一个工作表点击工作表新建一个工作簿点击工作簿工作表事件工作簿点击工作簿合并A1至C1的内容写到D15单元的批注中点击批注自动重算点击其他手动重算点击其他ＥＨ帖子地址net/dispbbs.asp?boardid=4&id=239820。
excel宏程序编程100例
excel宏程序编程100例Excel是一款功能强大的电子表格软件，它不仅可以进行数据的录入和计算，还可以通过宏程序实现自动化操作。
宏程序是一种自动化脚本，可以通过编程语言来实现对Excel的操作。
下面将介绍100个常用的Excel宏程序编程实例。
1. 创建一个新的工作表2. 删除一个工作表3. 复制一个工作表4. 移动一个工作表5. 隐藏一个工作表6. 显示一个工作表7. 设置工作表的名称8. 设置工作表的颜色9. 设置工作表的字体10. 设置工作表的边框11. 在指定位置插入一行12. 在指定位置插入一列13. 删除指定位置的行14. 删除指定位置的列15. 复制指定位置的行16. 复制指定位置的列17. 移动指定位置的行18. 移动指定位置的列19. 设置指定位置的单元格的值20. 设置指定位置的单元格的格式21. 设置指定位置的单元格的字体22. 设置指定位置的单元格的颜色23. 设置指定位置的单元格的边框24. 设置指定位置的单元格的公式25. 设置指定位置的单元格的链接26. 设置指定位置的单元格的数据验证27. 设置指定位置的单元格的条件格式28. 设置指定位置的单元格的批注29. 设置指定位置的单元格的合并30. 设置指定位置的单元格的拆分32. 设置指定位置的单元格的排序33. 设置指定位置的单元格的分组34. 设置指定位置的单元格的数据透视表35. 设置指定位置的单元格的图表36. 设置指定位置的单元格的条件格式37. 设置指定位置的单元格的数据透视表38. 设置指定位置的单元格的图表39. 设置指定位置的单元格的条件格式40. 设置指定位置的单元格的数据透视表41. 设置指定位置的单元格的图表42. 设置指定位置的单元格的条件格式43. 设置指定位置的单元格的数据透视表44. 设置指定位置的单元格的图表45. 设置指定位置的单元格的条件格式46. 设置指定位置的单元格的数据透视表47. 设置指定位置的单元格的图表49. 设置指定位置的单元格的数据透视表50. 设置指定位置的单元格的图表51. 设置指定位置的单元格的条件格式52. 设置指定位置的单元格的数据透视表53. 设置指定位置的单元格的图表54. 设置指定位置的单元格的条件格式55. 设置指定位置的单元格的数据透视表56. 设置指定位置的单元格的图表57. 设置指定位置的单元格的条件格式58. 设置指定位置的单元格的数据透视表59. 设置指定位置的单元格的图表60. 设置指定位置的单元格的条件格式61. 设置指定位置的单元格的数据透视表62. 设置指定位置的单元格的图表63. 设置指定位置的单元格的条件格式64. 设置指定位置的单元格的数据透视表65. 设置指定位置的单元格的图表66. 设置指定位置的单元格的条件格式67. 设置指定位置的单元格的数据透视表68. 设置指定位置的单元格的图表69. 设置指定位置的单元格的条件格式70. 设置指定位置的单元格的数据透视表71. 设置指定位置的单元格的图表72. 设置指定位置的单元格的条件格式73. 设置指定位置的单元格的数据透视表74. 设置指定位置的单元格的图表75. 设置指定位置的单元格的条件格式76. 设置指定位置的单元格的数据透视表77. 设置指定位置的单元格的图表78. 设置指定位置的单元格的条件格式79. 设置指定位置的单元格的数据透视表80. 设置指定位置的单元格的图表81. 设置指定位置的单元格的条件格式82. 设置指定位置的单元格的数据透视表83. 设置指定位置的单元格的图表84. 设置指定位置的单元格的条件格式85. 设置指定位置的单元格的数据透视表86. 设置指定位置的单元格的图表87. 设置指定位置的单元格的条件格式88. 设置指定位置的单元格的数据透视表89. 设置指定位置的单元格的图表90. 设置指定位置的单元格的条件格式91. 设置指定位置的单元格的数据透视表92. 设置指定位置的单元格的图表93. 设置指定位置的单元格的条件格式94. 设置指定位置的单元格的数据透视表95. 设置指定位置的单元格的图表96. 设置指定位置的单元格的条件格式97. 设置指定位置的单元格的数据透视表98. 设置指定位置的单元格的图表99. 设置指定位置的单元格的条件格式100. 设置指定位置的单元格的数据透视表以上是100个常用的Excel宏程序编程实例，通过这些实例，我们可以更好地掌握Excel宏程序的编程技巧，提高工作效率。
Excel自编宏大全(Word版)
目录之南宫帮珍创作（相同行删除、循环比力）（界说静态区域名称、不重复值公式宏、不重复值个数和行数公式宏、加边框宏）1, 从数据源匹配取数的问题Sub 宏131()'' 2007-1-31' Shizx98'Dim a As Range, Myrng1 As Range, Myrng2 As RangeDim Myrow As IntegerDim Myrow1 As IntegerDim Myrow2 As IntegerDim Myrow3 As IntegerDim x As IntegerWorksheets("Sheet1").ActivateRange("d2").SelectMyrow2 = Selection.Rows.Count 'D列数据的行数Range("a1").Select'AB列数据的行数Set Myrng1 = Range(Cells(2, 1), Cells(Myrow3, 1))Set Myrng2 = Range(Cells(2, 2), Cells(Myrow3, 2))For x = 2 To Myrow2 + 1Set a = Range("D" & x)For y = 1 To Myrow3If Len(a) > 7 ThenMyrow = Application.WorksheetFunction.Match(a, Myrng1, 0)ElseMyrow = Application.WorksheetFunction.Match(a, Myrng2, 0)End IfIf Myrow = 0 ThenGoTo 100ElseRange("F1").SelectRange(Cells(Myrow + 1, 1), Cells(Myrow + 1, 2)).SelectSelection.CutDestination:=Range(Cells(Myrow1 + 1, 6), Cells(Myrow1 + 1, 7))Selection.Delete Shift:=xlUpMyrow = 0MsgBox "已找到！"GoTo 200End If100: Next y200: Next xEnd Sub2, 部份字符地址查找‘2007/1/30‘Sub bfzfcz()Dim Myrow1 As IntegerDim Myrow2 As IntegerDim x%, y1%, y2%, gg%Dim AA, BBOn Error Resume NextRange("a2").SelectRange("e1").Selectgg = 2For x = 2 To Myrow2AA = Range("e" & x)For y1 = 2 To Myrow1 + 1BB = Application.WorksheetFunction.SearchB(AA, Cells(y1, 1))If BB > 0 ThenRange("g" & gg) = "A" & y1gg = gg + 1ElseEnd IfBB = 0Next y1For y2 = 2 To Myrow1 + 1BB = Application.WorksheetFunction.SearchB(AA, Cells(y2, 2))If BB > 0 ThenRange("g" & gg) = "B" & y2gg = gg + 1ElseEnd IfBB = 0Next y2'gg = gg + 1Next xEnd Sub3, 多表查询汇总和重复值问题（相同行删除、循环比力）Sub 宏0204()''见汇总0204.xls' 2007-2-4'蓝桥玄霜'年夜汇总问题'Dim x As Integer, y As IntegerDim rng1 As Range, tbl As RangeDim n As IntegerDim Myrow1 As Integer, Myrow2 As IntegerDim rng2Application.ScreenUpdating = FalseSheets("汇总").Select '清除总表原有的数据Range("a1").SelectIf tbl.Rows.Count > 1 Thentbl.Offset(1, 0).Resize(tbl.Rows.Count - 1,tbl.Columns.Count).ClearContentsElseEnd Ifn = 2Sheets("使用型号表").SelectRange("a1").SelectMyrow1=[a65536].End(xlUp).Row 'A列最下面一行的行数, 中间有空格也行For x = 2 To Myrow1Sheets("使用型号表").SelectSet rng1 = Range("B" & x) '依次把“使用数量”的值赋给rng1变量rng2 = Range("A" & x).Text '把序号里的表格名赋给rng2变量If rng1.Value <> "" ThenSheets("汇总Sheets(rng2).Select '用表格名选择表格Range("a1").SelectMyrow2 = Selection.CurrentRegion.Rows.Count'数据的行数Range(Cells(2, 2), Cells(Myrow2, 5)).Copy'复制这些数据Sheets("汇总").ActivateCells(n, 2).PasteSpecial '粘贴到汇总表Range(Cells(n, 6), Cells(Myrow2 + n - 2,6)).Select '选择F列相同行数Selection.FormulaR1C1 = "=RC[-1]*r1c6" '将使用数量X数量Range(Cells(n, 6), Cells(Myrow2 + n - 2,6)).Copy '复制这些数据Cells(n, 5).SelectSelection.PasteSpecialPaste:=xlValues'以“选择性粘贴”的“数值”粘贴Range(Cells(n, 6), Cells(Myrow2 + n - 2,6)).ClearContents '清除F列数量Cells(1, 6).ClearContentsn = n + Myrow2 - 1 '为下次粘贴数据的行位置ElseEnd IfNext xbcfhz0204 '不重复汇总的宏Application.ScreenUpdating = TrueEnd SubSub bcfhz0204()'不重复汇总'蓝桥玄霜'2007-2-4Dim b As Integer, x As Integer, y As Integer, aa AsInteger, yyy As IntegerDim minc As RangeDim rng1 As Range, a As RangeDim n1 As Integer, nn As Integer, Myrow1 As IntegerDim pp, pp1On Error Resume NextSheets("汇总").SelectRange("a1").SelectMyrow1 = Selection.CurrentRegion.Rows.Count 'A列数据的行数Set minc = Range("b2:b" & Myrow1)Set rng1 = Range("m2:m" & Myrow1)Range("m2").Select'求重复值个数的辅助列公式Selection.Formula ="=if((countif(minc,$b2)>1)*(match($b2,minc,0)=row($a1)),count(m$1:m1)+1,"""")"Selection.AutoFill Destination:=rng1,Type:=xlFillDefault '公式往下复制b = Application.WorksheetFunction.Max(rng1)Range("n2").Select '求重复值的辅助列公式Selection.Formula ="=if(iserror(index(minc,match(row(b1),m$2:m$65536,0))),"""",index(minc,match(row(b1),m$2:m$65536,0)))"Selection.AutoFill Destination:=Range("n2:n" & b + 1), Type:=xlFillDefault '公式往下复制Range("n2:n" & b + 1).Select'以“选择性粘贴”的“数值”粘贴n,m列, 因为删除一行后,公式会重新计算 'Range("n2").SelectSelection.PasteSpecial Paste:=xlValuesRange("m2").SelectSelection.PasteSpecial Paste:=xlValuesFor x = 2 To b + 1Set a = Range("n" & x)aa = Application.WorksheetFunction.CountIf(minc,a) '计算重复值的个数Range("o" & x).Value = aann = aaRange("p1") = aRange("p2").Select '重复值所在行数的数组公式Selection.FormulaArray ="=if($p$1<>"""",if(iserror(small(if(minc=$p$1,row(minc)," """),row(1:1))),"""",small(if(minc=$p$1,row(minc),""""),row(1:1))))"Selection.AutoFill Destination:=Range("p2:p" & aa+ 1), Type:=xlFillDefaultRange("p2:p" & aa + 1).SelectRange("p2").SelectSelection.PasteSpecial Paste:=xlValues'以“选择性粘贴”的“数值”粘贴去除公式影响For y = 2 To nn '在重复值里循环比力pp = Range("p" & y).Value '将行数赋给变量ppFor yy = y + 1 To nn + 1pp1 = Range("p" & yy).Value '将行数赋给变量pp1If pp1 = "" ThenGoTo 100ElseEnd IfIf Cells(pp, 2) = Cells(pp1, 2) And Cells(pp, 3) = Cells(pp1, 3) And Cells(pp, 4) = Cells(pp1, 4) ThenCells(pp, 5) = Cells(pp, 5) + Cells(pp1, 5) '汇总部份Range(Cells(pp1, 1), Cells(pp1, 5)).Delete shift:=xlUp'删除过剩的行For yyy = yy + 1 To nn + 1Range("p" & yyy) = Range("p" & yyy) - 1Next yyyRange("p" & yy).Delete shift:=xlUpyy = yy - 1: nn = nn - 1ElseEnd IfNext yy100: Next ynn = aaRange("p1:P" & aa + 1).ClearContents '清除辅助列数据200: Next xRange("m1").SelectSelection.CurrentRegion.ClearContents '清除辅助列数据Range("A1").Select '以下在A列加上序号Range("A2").SelectActiveCell.FormulaR1C1 = "1"Range("A3").SelectActiveCell.FormulaR1C1 = "2"Range("A2:A3").SelectSelection.AutoFill Destination:=Range("A2:A" & n1), Type:=xlFillDefaultRange("A2").SelectEnd Sub4, 工作表的名称和index号Sub Sheetsname()‘见上例的xls‘2007-2-2Dim Sht As WorksheetSheets("使用型号表").Activaten = 2If <> "汇总" And <> "使用型号表" Thenn = n + 1ElseEnd IfNext ShtEnd Sub5, 重复值加色Sub 重复值加色()'' 蓝桥玄霜2007-2-2'表格中有重复值公式'Dim rng1 As Range, data As RangeDim b As IntegerSet rng1 = Range("n2:n117")‘重复值区域b = Application.WorksheetFunction.Max(rng1)‘重复值个数Range("B2:B117").SelectFor X = 2 To b + 1‘用查找Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _Formula1:="=$M$" & XSelection.FormatConditions(X - 1).Interior.ColorIndex = 3Next XEnd Sub6, 统计Sub tongji()‘‘Excel论坛Dim Myrow1 As Integer, Myrow2 As IntegerDim Sht As Worksheet, Sht1 As WorksheetApplication.ScreenUpdating = FalseOn Error Resume NextFor Each Sht In ActiveWorkbook.Worksheets 'AB列空格填充 If <> "月计" ThenSheets().SelectRange("a1").SelectMyrow1 = [a65536].End(xlUp).Row 'A列最下面一行的行数, 中间有空格也行Set rng1 = Range(Cells(4, 1), Cells(Myrow1 -1, 2))IfIsError(Selection.SpecialCells(xlCellTypeBlanks)) ThenGoTo 100ElseSelection.SpecialCells(xlCellTypeBlanks).SelectRange("A5").ActivateSelection.FormulaR1C1 = "=R[-1]C"Range("A4").SelectSelection.PasteSpecial Paste:=xlValuesApplication.CutCopyMode = FalseRange("A4").SelectEnd IfElseEnd If100: Next ShtSheets("月计").SelectSet Sht1 = Sheets("月计")Range("a1").SelectMyrow1 = [a65536].End(xlUp).RowMyrow1 = Myrow1 - 1Range(Cells(4, 4), Cells(Myrow1, 11)).ClearContentsFor x = 4 To Myrow1fa = Range("a" & x).Valuedao = Range("b" & x).ValueIf fa = "" And dao = "" ThenGoTo 200ElseEnd IfFor n = 1 To 10Sheets(n).ActivateRange("a1").SelectMyrow2 = [a65536].End(xlUp).RowMyrow2 = Myrow2 - 1For y = 4 To Myrow2fa1 = Range("a" & y).Valuedao1 = Range("b" & y).ValueIf fa = fa1 And dao = dao1 ThenSht1.Range("d" & x) = Sht1.Range("d" & x) + Range("d" & y) '汇总Sht1.Range("e" & x) = Sht1.Range("e" & x) + Range("e" & y)Sht1.Range("f" & x) = Sht1.Range("f" & x) + Range("f" & y)Sht1.Range("g" & x) = Sht1.Range("g" & x) + Range("g" & y)Sht1.Range("h" & x) = Sht1.Range("h" & x) + Range("h" & y)Sht1.Range("i" & x) = Sht1.Range("i" & x) + Range("i" & y)Sht1.Range("j" & x) = Sht1.Range("j" & x) + Range("j" & y)Sht1.Range("k" & x) = Sht1.Range("k" & x) + Range("k" & y)ElseEnd IfNext yNext nSheets("月计").Select200: Next xSheets("月计").SelectApplication.ScreenUpdating = TrueEnd Sub7, 最年夜或最小‘Excel论坛‘Sub MaxMin()Dim rng1 As RangeDim x As Integer, b As IntegerDim a(12)Range("a14").Value = ""For x = 1 To 12Cells(2, x + 3).SelectSet rng1 = Cells(2, x + 3)b = Application.WorksheetFunction.Find("/", rng1)a(x) = Left(rng1, b)a(x) = Val(a(x))Next xMymax = Application.WorksheetFunction.Max(a(1), a(2), a(3), a(4), a(5), a(6), a(7), a(8), a(9), a(10), a(11), a(12))Mymin = Application.WorksheetFunction.Min(a(1), a(2), a(3), a(4), a(5), a(6), a(7), a(8), a(9), a(10), a(11), a(12))If a(1) = Mymax ThenRange("a14").FormulaR1C1 = "最年夜"ElseIf a(1) = Mymin ThenRange("a14").FormulaR1C1 = "最小"ElseEnd IfEnd IfEnd Sub8, 最后一记录（界说名称）Sub zhytjl0206()'Shizx98'2007-2-6‘hDim b As Integer, x As Integer, y As Integer, aa As IntegerDim minc As RangeDim rng1 As Range, a As RangeDim nn As Integer, Myrow1 As IntegerDim pp, pp1Dim Sht1 As Worksheet, Sht2 As WorksheetOn Error Resume NextApplication.ScreenUpdating = FalseSet Sht1 = Sheets(1): Set Sht2 = Sheets(3)s.Add Name:="data1", RefersToR1C1:= _"=OFFSET(Sheet1!R1C1,1,,COUNTA(Sheet1!R2C1:R65535C1),)"Range("n1").SelectSelection.CurrentRegion.ClearContents '清除辅助列数据Range("a1").SelectSelection.CurrentRegion.ClearContents '清除上次数据 Sht1.Range("a1:g1").Copy Sheet2.[a1]Range("a1").SelectMyrow1 = Selection.CurrentRegion.Rows.Count 'A列数据的行数Set minc = Range("a2:a" & Myrow1)Set rng1 = Range("n2:n" & Myrow1)BcfzGS '转求不重复值宏For x = 2 To b + 1FuzulieGS '转辅助列公式宏Range("p2:p" & aa + 1).SelectSelection.Copy Sht2.Range("a2")Application.CutCopyMode = Falsepp = Sht1.Range("p" & 2).Value '将行数赋给变量ppRange(Cells(pp, 7), Cells(pp + aa - 1,7)).SelectSelection.Copy Sht2.Range("b2") '时间复制到表2Cells(2, 3).SelectSelection.Formula = "=datevalue(rc[-1])+timevalue(rc[-1])" '时间值公式If aa > 1 ThenSelection.AutoFillDestination:=Range("c2:c" & aa + 1), Type:=xlFillDefault '公式往下复制Range("a2:c" & aa + 1).SelectSelection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlNo, _OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinElseEnd Ifpp1 = Range("a2").ValueSheets(2).SelectFor xx = 1 To 7Cells(x, xx) = Sht1.Cells(pp1, xx)Next xxnn = aaRange("p1:P" & aa + 1).ClearContents '清除辅助列数据Range(Cells(1, 1), Cells(aa + 1, 3)).ClearContents200: Next xRange("m1").SelectSelection.CurrentRegion.ClearContents '清除辅助列数据Sheets(2).ActivateRange("a1:g" & b + 1).Select‘排序Selection.Sort Key1:=Range("a1"), Order1:=xlAscending,Header:=xlGuess, _OrderCustom:=2, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYin加边框'转加边框宏Range("A1").SelectApplication.ScreenUpdating = TrueEnd SubSub BcfzGS()'不重复值公式Range("n2").Select '辅助列公式求有几个不重复值Selection.FormulaArray = "=index(a:a,min(if(countif(n$1:n1,data1),65536,row(data1) )))&"""""Selection.AutoFill Destination:=rng1, Type:=xlFillDefault '公式往下复制b = Application.WorksheetFunction.CountIf(rng1, "4*") End SubSub FuzulieGS()'某个不重复值的个数和所在行数的数组公式Set a = Range("n" & x)aa = Application.WorksheetFunction.CountIf(minc, a) '计算某个不重复值的个数Range("o" & x).Value = aann = aaRange("p1") = Val(a)Range("p2").Select '某个不重复值所在行数的数组公式Selection.FormulaArray = "=if($p$1<>"""",if(iserror(small(if(minc=$p$1,row(minc)," """),row(1:1))),"""",small(if(minc=$p$1,row(minc),""""),r ow(1:1))))"If aa > 1 ThenSelection.AutoFillDestination:=Range("p2:p" & aa + 1), Type:=xlFillDefaultElseEnd IfEnd SubSub 加边框()BorderVars(1) = xlEdgeLeftBorderVars(2) = xlEdgeTopBorderVars(3) = xlEdgeBottomBorderVars(4) = xlEdgeRightBorderVars(5) = xlInsideVerticalBorderVars(6) = xlInsideHorizontalRange("a1:g" & b + 1).SelectSelection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone For x = 1 To 6With Selection.Borders(BorderVars(x)).LineStyle = xlContinuous.Weight = xlThin.ColorIndex = xlAutomaticEnd WithNextEnd SubSub zhytjl0215()'最后一条记录'蓝桥玄霜,'2007-2-15'根据czzqbµ的数组公式修改'在表1的H列加了时间转换公式Dim b As Integer, x As Integer, y As IntegerDim minc As Range。
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
EXCEL宏代码大全
本文件部分文章来源于网络，文章版权归原作者所有，如果本站转载的文章侵犯了您的权益请及时联系我们，我们将尽快妥善处理。
本站除部分特别声明禁止转载的专稿外，其他文章可以自由转载，但请务必注明原出处和作者。
000. A列半角内容变红
Sub A列半角内容变红() ? Dim rg As Range, i As Long ? Application.ScreenUpdating = False ? For Each rg In Cells.SpecialCells(xlCellTypeConstants, 3) For i = 1 To Len(rg) ?? If Asc(Mid(rg, i, 1))
001. A列等于A列减B列
Sub A列等于A列减B列() For i = 1 To 23 Cells(i, 1) = Cells(i, 1) - Cells(i, 2) Next End Sub 002. B列录入数据时在A列返回记录时间（工作表代码）
Public Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then Target.Offset(, -1) = Now End If End Sub
003. Excel宏常用代码
本大类暂没有内容，以下是关于本类的所有记录集。
004. Sub 以当前日期为名称另存文件()
ActiveWorkbook.SaveAs Filename:=Date & ".xls" End Sub
005. Sub 启用保存()
mandBars("File").Controls(4).Enabled = True
mandBars("File").Controls(5).Enabled = True End Sub
006. Sub 执行前需要验证密码的宏()
If InputBox("请输入您的使用权限:", "系统提示") = 123 Then 重排窗口'要执行的宏代码或宏名称Else MsgBox "对不起,您没有使用该宏的权限,按确定键后退出!" End If End Sub
007. Sub 选择第5行开始所有数据行B()
Rows("5:" & Cells.Find("*", , , , 1, 2).Row).Select End Sub
008. VBA返回公式结果
Sub VBA返回公式结果() x = Application.WorksheetFunction.Sum(Range("a2:a100")) Range("B1") = x End Sub
009. 不连续区域录入对勾
Sub 批量录入对勾() Selection.FormulaR1C1 = "√" End Sub
010. 不连续区域录入当前单元地址
Sub 区域录入当前单元地址() For Each mycell In Selection mycell.FormulaR1C1 = mycell.Address Next End Sub
011. 不连续区域录入当前数字日期
Sub 区域录入当前数字日期() Selection.FormulaR1C1 = Format(Now(), "yyyymmdd") End Sub
012. 不连续区域录入当前文件名
Sub 批量录入当前文件名() Selection.FormulaR1C1 = End Sub
013. 不连续区域录入当前日期
Sub 区域录入当前日期() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d") End Sub
014. 不连续区域录入当前日期和时间
Sub 区域录入当前日期和时间() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss") End Sub
015. 不连续区域插入当前文件名和表名及地址
Sub 批量插入当前文件名和表名及地址() For Each mycell In Selection mycell.FormulaR1C1 = "[" + + "]" + + "!" + mycell.Address Next End Sub
016. 不连续区域插入文本
Sub 批量插入文本() Dim s As Range For Each s In Selection s = "文本内容" & s Next End Sub
017. 不连续区域添加文本
Sub 批量添加文本() Dim s As Range For Each s In Selection s = s & "文本内容" Next End Sub
018. 为当前选定的多单元插入指定名称
Sub 为当前选定的多单元插入指定名称() = "临时" s.Add Name:="临时", RefersTo:=Selection '或者换用这行代码也可以End Sub
019. 为指定工作表加指定密码保护表
Sub 为指定工作表加指定密码保护表() Sheet10.Protect Password:="123" End Sub
020. 为指定工作表设置滚动范围（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Sheet1.ScrollArea = "A1:M30" End Sub
021. 从指定位置向下同时录入多单元指定内容
Sub 从指定位置向下同时录入多单元指定内容() Dim arr arr = Array("1", "2", "13", "25", "46", "12", "0", "20") [B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr) End Sub
022. 以A1单元内容批量插入批注
Sub 以A1单元内容批量插入批注() Dim r As Range If Selection.Cells.Count > 0 Then For Each r In Selection r.AddComment ment.Visible = False ment.Text Text:=[a1].Text Next End If End Sub
023. 以A1单元文本作表名插入工作表
Sub 以A1单元文本作表名插入工作表() Dim nm As String nm = [a1] Sheets.Add = nm End Sub
024. 以当前日期为新文件名另存文件
Sub 以当前日期为新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls" End Sub
025. 以当前日期和时间为新文件名另存文件
Sub 以当前日期和时间为新文件名另存文件() ThisWorkbook.SaveAs。