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 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:="临时", RefersT o:=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].T ext 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 ThisWorkbook.Path & "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls" End Sub
026. 以指定区域为表目录补充新表
Sub 以指定区域为表目录补充新表() Dim dic As Object, sh As
Worksheet 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 Sub
028. 以本工作表名称另存文件到当前目录
Sub 以本工作表名称另存文件到当前目录() ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & & ".xls" End Sub
029. 以活动工作表名称另存文件到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 Sub
031. 保存并退出Excel
Sub 保存并退出Excel() Application.SendKeys ("{ENTER}{ENTER}%fx") ActiveWorkbook.Save End Sub
032. 保护工作表时取消选定锁定单元
Sub 取消选定锁定单元() ActiveSheet.EnableSelection =
xlUnlockedCells ''用于2000版 End Sub
033. 光标定位到名称指定位置
Sub 定位() Application.Goto Range(Evaluate("名称")) End Sub
034. 光标定位到指定工作表A列最后数据行下一单元
Sub 光标定位到指定工作表A列最后数据行下一单元() a = Sheets("数据库").[a65536].End(xlUp).Row Sheets("数据库").Select Range("A" & a + 1).Select End Sub
035. 光标所在行上移一行
Sub 光标所在行上移一行() Dim i% i = Split(ActiveCell.Address, "$")(2) If i > 1 Then Rows(i).Cut Rows(i - 1).Insert Shift:=xlDown End If End Sub
036. 光标移动
Sub 光标移动() ActiveCell.Offset(1, 2).Select ''向下移动1行，向右移动2列 End Sub
037. 全选固定范围内小于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 Sub
038. 全选选定范围内小于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 Sub
039. 全部显示指定表的自动筛选
Sub 全部显示指定表的自动筛选() If Sheet1.FilterMode = True Then Sheet1.ShowAllData End If End Sub
040. 全部清除当前选择区域
Sub 全部清除当前选择区域() Selection.Clear '' Range("A1:B10").Clear ''全部清除指定区域 End Sub
041. 关闭文件时执行指定宏(工作簿代码)
Private Sub Workbook_BeforeClose(Cancel As Boolean) 重排窗口 ''要执行的宏名称 End Sub
042. 关闭文件时自动隐藏指定工作表(ThisWorkbook)
Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Unprotect Sheets("Sheet2").Visible = False Sheets("Sheet3").Visible = False ActiveWorkbook.Protect Structure:=True, Windows:=Fal
043. 分离临时表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 Sub
046. 删除A列空行
Sub 删除A列空行() Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub
047. 删除A列非数字单元行
Sub 删除A列非数字单元行() i = [a65536].End(xlUp).Row Range("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End Sub
048. 删除B列数据的超链接
Sub 删除超链接() For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)
Sheet1.Range(Rng.Address).Hyperlinks.Delete Next End Sub
049. 删除全部名称
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 Sub
050. 删除全部未选定工作表
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.Selec
051. 删除包含固定文本单元的行或列
Sub 删除包含固定文本单元的行或列() Do Cells.Find(what:="哈哈").Activate Selection.EntireRow.Delete ''删除行 '' Selection.EntireColumn.Delete ''删除列 Loop Until Cells.Find(what:="哈哈") Is Nothing End Sub
052. 删除指定文件
Sub 删除指定文件() Kill "E:\信件\1.xls" End Sub
053. 删除指定行
Sub 删除指定行() Workbooks("临时表").Sheets("表2").Range("5:5").Delete End Sub
054. 判断指定文件是否已经打开
Sub 判断指定文件是否已经打开() Dim x As Integer For x = 1 To Workbooks.Count If Workbooks(x).Name = "函数.xls" Then ''文件名称 MsgBox "文件已打开" Exit Sub End If Next MsgBox "文件未打开" End Sub
055. 加数据有效限制
Sub 加数据有效限制() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="******************".IgnoreBlank = False .InCellDropd
056. 单元区域引用（工作表代码）
Private Sub Worksheet_Activate()
Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").Value End Sub
057. 单元反选
Sub 单元反选() Application.DisplayAlerts = False Application.ScreenUpdating = False Dim raddress As String, taddress As String raddress = Selection.Address taddress = edRange.Address
058. 单元格录入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 Sub
060. 去除指定范围内的对象
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 Next
061. 双击单元执行宏(工作表代码)
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 Sub
063. 双击指定区域单元执行宏(工作表代码)
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 Then
064. 双击指定单元，循环录入文本（工作表代码）
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.Offse
065. 反方向文本(自定义函数)
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 Sub
067. 取消数据有效限制
Sub 取消数据有效限制() With
Selection.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = False .InCellDropdown = False .InputTitle =
068. 取消自动筛选()
Sub 取消自动筛选() ActiveSheet.AutoFilterMode = False End Sub
069. 取消选定区域的公式只保留值(假空转真空)
Sub 取消选定区域的公式只保留值() ?''?? Sheets("数据归并集中").Select ''指定工作表 ?''?? Columns("Q:R").Select ''指定范围 Selection.Value = Selection.Value End Sub
070. 另存所有工作表为工作簿
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 Sub
072. 另存本表为TXT文件
Sub 另存本表为TXT文件() Dim s As String Dim FullName As String, rng As Range Application.ScreenUpdating = False FullName = ( & ".txt") ''以当前表名为TXT文件名 '' FullName = Replace(ThisWorkboo
073. 右侧单元自动加5(工作表代码)
Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target.Offset(0, 1) = T arget + 5 Application.EnableEvents = True End Sub
074. 合并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:i
075. 合并各工作表内容
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 st
076. 合并指定目录中所有文件中相同格式工作表的数据
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%, i
077. 回车光标向下
Sub 录入光标向下() Application.MoveAfterReturnDirection = xlDown End Sub
078. 回车光标向右
Sub 录入光标向右() Application.MoveAfterReturnDirection =
xlToRight End Sub
079. 固定区域单元分类变色
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 Sub
081. 在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 Sub
083. 在F1单元显示光标位置批注内容的代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range) a = Selection.Address b = Range(a).NoteText Cells(1, 6) = b End Sub
084. 在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 Target
085. 在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）
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 S
086. 在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）
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 Sub
088. 在当前工作组各表中分别执行指定宏
''northwolves版主解答 /dispbbs.asp?boardid=2&id=251426&star=2#914934 Sub 在当前工作组各表中分别执行指定宏() Dim SH As Worksheet For Each SH In ActiveWindow.SelectedSheets SH.Activate 临时 N
089. 在当前选区有条件替换数值为文本
Sub 在当前选区有条件替换数值为文本() For Each r In Selection If r.Value > 18 And r.Value < 29.5 Then r.Value = "Y" Next End Sub
090. 在所有工作表的A1单元返回顺序号
Sub 在所有工作表的A1单元返回顺序号() For i = 1 T o Sheets.Count Sheets(i).Cells(1, 1) = "''" & Application.WorksheetFunction.Text(0 + i, "000") Next End Sub
091. 在指定区域选择单元时数值加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 Sub
092. 在指定单元记录打印和预览次数（工作簿代码）
Private Sub Workbook_BeforePrint(Cancel As Boolean) Range("A1") = 1 + Range("A1") End Sub
093. 在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Worksheets("表2").Range("A1") = Target.Address(0, 0) End Sub
094. 在有密码的工作表执行代码
Sub 在有密码的工作表执行代码() Sheets("1").Unprotect Password:=123 ''假定表名为“1”，密码为“123”打开工作表 Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True ''隐藏C列空值行 Sheets("1").Protect Password:=123
095. 在目录表建立本工作簿中各表链接目录
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 Sub
097. 填公式
Sub 填公式() Range("C2:C12").Value = "=SUM(A2:B2)" End Sub
098. 处理导入的显示为科学计数法样式的身份证号
Sub 处理导入的显示为科学计数法样式的身份证号() Selection.Value = Selection.Formula End Sub
099. 复制单元数值
Sub 复制数值() s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2") Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = s End Sub
100. 复制单元格所在列
Sub 复制单元格所在列() Selection.EntireColumn.Copy End Sub
101. 复制单元格所在行
Sub 复制单元格所在行() Selection.EntireRow.Copy End Sub
102. 复制当前工作簿的报表到临时工作簿
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 Workbook
103. 奇偶页分别打印
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 "现在打印偶数页,按确定开始." For
104. 定义指定工作表标签颜色
Sub 定义指定工作表标签颜色() Sheets("Sheet1").T ab.ColorIndex = 46 End Sub
105. 定位数据及区域以上的空值
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.Select
106. 定位选定单元格式相同的全部单元格
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)为指定的工作表。

这个宏指向的是当前
108. 对指定工作表执行取消隐藏》打印》隐藏工作表
Sub 打印隐藏工作表() Sheets("报表1").Visible = 1 Sheets("报表1").PrintOut Copies:=1, Collate:=True Sheets("报表1").Visible = 0 End Sub
109. 对第一张工作表的指定区域进行排序
Sub 对第一张工作表的指定区域进行排序() With Worksheets(1) .Range("a2:a100").Sort Key1:=.Range("a1") End With End Sub
110. 将A1单元录入的数据累加到B1单元（工作表代码）
Private Sub Worksheet_Change(ByVal Target As Range) Dim t As Long If Target.Address = "$A$1" Then t = Sheet1.Range("$B$1").Value Sheet1.Range("$B$1").Value = t + Target.Value End If End Sub
111. 将A列数据排序到D列
Sub 将A列数据排序到D列() [d:d] = [a:a].Value [d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes End Sub
112. 将A列数据随机排列到F列
Sub 将A列数据随机排列到F列() Dim n As Long n = [a65536].End(xlUp).Row [f1].Resize(n, 1) = [a1].Resize(n, 1).Value [g1].Resize(n, 1) = "=rand()" [f:g].Sort [g1] [g:g] = "" End Sub
113. 将A列最后数据行以上的所有B列图片大小调整为所在单元大小
Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小() Dim Pic As Picture, i& i = [A65536].End(xlUp).Row For Each Pic In Sheet1.Pictures If Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing The
114. 将B列数据添加超链接到K列
Sub 将B列数据添加超链接到K列() For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row) ActiveSheet.Hyperlinks.Add Anchor:=Rng, Address:="", SubAddress:=Sheet1.Range("K" & Rng.Row).Address, ScreenTip:="点击转到:" &
115. 将Sheet1的A列的非空值写到Sheet2的A列
Sub 将Sheet1的A列的非空值写到Sheet2的A列() Sheet1.Columns("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1] End Sub
116. 将全部工作表名称写到A列
Sub 将全部表名称写到A列() k = 1 For Each Sht In Sheets Cells(k + 1, 1) = ''指定写入的行和列 k = k + 1 Next End Sub
117. 将全部工作表的A1单元作为单击按钮（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As
Object, ByVal Target As Range) If Target.Address = "$A$1" Then Call 宏名 End If End Sub
118. 将名称1的数据写到名称2
Sub Macro2() Range("位置2") = Range("位置1").Value End Sub
119. 将所选区域文本插入新建文本框
Sub 将所选区域文本插入新建文本框() For Each rag In Selection n = n & rag.Value & Chr(10) Next ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + Act
120. 将指定范围的数据排列到D列
Sub 将指定范围的数据排列到D列() Dim arr1, arr2, i%, x arr1 = Range("A1:C3") ReDim arr2(1 T o UBound(arr1, 1) * UBound(arr1, 2), 1 To 1) For Each x In Application.Transpose(arr1) i = i + 1 arr2(i, 1) = x Ne
121. 将本工作表单独另存文件到Excel当前默认目录
Sub 将本工作表单独另存文件到Excel当前默认目录() ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:= & ".xls" End Sub
122. 将第5行移到窗口的最上面
Worksheets("Sheet1").Activate ActiveWindow.ScrollRow = 5
123. 工作表中包含数据的最大行数
Sub 包含数据的最大行数() n = Cells.Find("*", , , , 1, 2).Row MsgBox n End Sub
124. 工作表标签排序
Sub 工作表标签排序() Dim i As Long, j As Long, nums As Long, msg As Long msg = MsgBox("工作表按升序排列请选 ''是[Y]''. " & vbCrLf & vbCrLf & "工作表按降序排列请选 ''否[N]''", vbYesNoCancel, "工作表排序") If msg = vbCancel Then Exit
125. 延时15秒执行重排窗口宏
Sub 延时15秒重排窗口() Application.OnTime Now + TimeValue("00:00:15"), "重排窗口" End Sub
126. 建立工作表文本目录
Sub 建立工作表文本目录() Sheets.Add before:=Sheets(1) Sheets(1).Name = "目录" For i = 2 T o Sheets.Count Cells(i - 1, 1) = Sheets(i).Name ''Sheets(1).Hyperlinks.Add Cells(i - 1, 1), "#" & Sheets(i).Name & "
127. 建立当前工作表的副本为001表
Sub 建立当前工作表的副本为001表() ActiveSheet.Copy Before:=Sheets(1) = "001" End Sub
128. 引用指定位置单元内容为部分文件名另存文件
Sub 引用指定位置单元内容为部分文件名另存文件() ActiveWorkbook.SaveAs Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls" End Sub
129. 弹出打印对话框
Sub 弹出打印对话框() Application.Dialogs(xlDialogPrint).Show End Sub
130. 弹出提示A1单元内容
Sub 弹出提示A1单元内容() MsgBox "提示" & Range("A1").Value End Sub
131. 强行合并单元
Sub 强行合并单元() Application.DisplayAlerts = False ''不出现对话框，按对话框默认选择Range("a3:a4").Merge Application.ScreenUpdating = True End Sub
132. 当修改指定单元内容时自动执行宏（工作表代码）
Private Sub Worksheet_Change(ByVal Target As Range) If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then 重排窗口 End If End Sub
133. 当前单元内容返回到按钮名称（控件按钮代码）
Private Sub CommandButton1_Click() CommandButton1.Caption = ActiveCell End Sub
134. 当前单元加2
Sub 当前单元加2() Selection = Selection + 2 ''Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容 End Sub
135. 当前单元录入计算机名
Sub 当前单元录入计算机名() Selection = Environ("COMPUTERNAME") ''Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容 End Sub
136. 当前单元录入计算机用户名
Sub 当前单元录入计算机用户名() Selection = Environ("Username") ''Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容 End Sub
137. 当前单元返回按钮名称（控件按钮代码）
Private Sub CommandButton1_Click() ActiveCell = CommandButton1.Caption End Sub
138. 当前文件另存到指定目录
Sub 当前激活文件另存到指定目录() ActiveWorkbook.SaveAs Filename:="E:\信件\" & End Sub
139. 当前行下插入1行
Sub 当前行下插入1行() Selection.Offset(1, 0).Insert End Sub
140. 当前选区的行列数
Sub 当前选区的行列数() Range("A1") = Selection.Rows.Count ''当前选区的行数 Range("B1") = Selection.Columns.Count ''当前选区的列数 End Sub
141. 当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）
Public Sub Worksheet_Change(ByVal Target As Range) If Not Application.Intersect(Target, [A1:A1000]) Is Nothing Then If Target.Column = 1 Then Target.Offset(, 1) = Date Target.Offset(, 2) = Time
142. 当指定日期（每月10日）打开文件执行宏
Sub auto_open() If Day(Date) = 10 Then 重排窗口 End If End Sub
143. 录制宏时调用“停止录制”工具栏
Sub 录制宏时调用停止录制工具栏() mandBars("Stop Recording").Visible = True End Sub
144. 循环宏
Sub 循环() AAA = Range("C2") Dim i As Long Dim times As Long times = AAA ''times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647) For i = 1 To times Call 过滤一行 If Range("完成标志") = "完成" Then Exit For
145. 手动重算
Sub 手动重算() With Application .Calculation = xlManual End With End Sub
146. 打开全部隐藏工作表
Sub 打开全部隐藏工作表() Dim i As Integer For i = 1 To Sheets.Count Sheets(i).Visible = True Next i End Sub
147. 打开文件时执行指定宏(工作簿代码)
Private Sub Workbook_Open() 重排窗口 ''要执行的宏名称 End Sub
148. 打开文件时提示指定工作表是保护状态(ThisWorkbook)
Private Sub Workbook_Open() If Worksheets("Sheet1").ProtectContents = True Then MsgBox " Sheet1保护了." End If End Sub
149. 执行前需要验证密码的宏(控件按钮代码)
Private Sub CommandButton1_Click() If InputBox("请输入密码：") <> "123" Then ''密码是123 MsgBox "密码错误,按确定退出!", 64, "提示" Exit Sub End If Cells(1, 1) = 10 End Sub
150. 批量处理单元格
Dim rng As Range Application.ScreenUpdating = False For Each rng In Selection If rng <> "" Then rng = rng * 7 Next
151. 批量插入地址批注
Sub 批量插入地址批注() On Error Resume Next Dim r As Range If Selection.Cells.Count > 0 Then For Each r In Selection ment.Delete r.AddComment ment.Visible = False ment.Text Text:="本单元格：
152. 批量插入统一批注
Sub 批量插入统一批注() Dim r As Range, msg As String msg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧") If Selection.Cells.Count > 0 Then For Each r In Selection r.AddComment ment.Visible = False r.Co
153. 批量清除软回车
Sub 批量清除软回车() ''也可直接使用Alt+10或13替换 Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:= _ xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub
154. 把a列不重复值取到e列
Sub 把a列不重复值取到e列() [A:A].AdvancedFilter 2, , [e1], 1 End Sub
155. 拷贝A1公式和格式到A2
Sub 拷贝A1公式到A2() Workbooks("临时表").Sheets("表1").Range("A1").Copy Workbooks("临时表").Sheets("表2").Range("A2").PasteSpecial End Sub
156. 拷贝指定表不相邻多列数据到新位置
Sub 拷贝指定表不相邻多列数据到新位置() Sheets("sheet1").Range("A:A,J:J").Copy Range("d1") End Sub
157. 指定允许编辑区域
Sub 指定允许编辑区域() ActiveSheet.ScrollArea = "B8:G15" End Sub
158. 指定区域单元双击数据累加（工作表代码）
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Application.Intersect([A1:Y100], Target) Is Nothing Then oldvalue = Val(Target.Value) inputvalue = InputBox
159. 指定单元显示光标位置内容（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal T As Range) Sheets(1).Range("A1") = Selection End Sub
160. 指定单元的行高和列宽与A1单元相同
Sub 指定单元的行高和列宽与A1单元相同() Range("A1:F1").ColumnWidth = Range("A1").ColumnWidth ''指定列宽 Range("A2:A10").RowHeight = Range("A1").RowHeight ''指定行高 End Sub
161. 指定行高和列宽
Sub 指定行高和列宽() Range("A1:F1").ColumnWidth = 10 ''指定列宽 Range("A2:A10").RowHeight = 40 ''指定行高 End Sub Sub 指定行高和列宽() Columns("A:F").ColumnWidth = 10 ''指定列宽Rows("2:10").RowHeight = 40 ''指定行高
162. 指定选择单元区域弹出消息
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$A$1:$C$3" Then MsgBox "你选择对了" End If End Sub
163. 按aa工作表A列的内容排列工作表标签顺序
Sub 按aa工作表A列的内容排列工作表标签顺序() Dim I%, str1$ I = 1 Sheets("aa").Select Do While Cells(I, 1).Value <> "" str1 = Trim(Cells(I, 1).Value) Sheets(str1).Select Sheets(str1).Move after:=Sheets(I) I =
164. 按A列数据批量修改表名称
Sub 按A列数据批量修改表名称() Dim i% For i = 1 To Sheets.Count - 1 Sheets(i).Name = Cells(i + 1, 1).Text Next End Sub
165. 按A列数据批量创建新表(控件按钮代码)
Private Sub CommandButton1_Click() On Error Resume Next Dim i%, j% For i = 1 To [a65536].End(xlUp).Row For j = 2 T o Sheets.Count If Cells(i, 1) = Sheets(j).Name Then Exit For End If Next She
166. 按光标选定颜色隐藏本列其他颜色行
Sub 按颜色筛选() ''思路就是:其它背景色之行全部隐藏 Dim。