Excel_259个常用宏

▲打开全部隐藏工作表

返回

Sub 打开全部隐藏工作表()Dim i As Integer

For i = 1 To Sheets.Count Sheets(i).Visible = TrueNext iEnd Sub

▲循环宏

返回

Sub 循环()

AAA = Range(\"C2\")

Dim i As Long Dim times As Long times = AAA

'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于21474837) For i = 1 To timesCall 过滤一行

If Range(\"完成标志\") = \"完成\" Then Exit For '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则 'If Sheets(\"传送参数\").Range(\"A\" & i).Text = \"完成\" Then Exit For '如果某列出现\"完成\"内容则退出循环 Next iEnd Sub

▲录制宏时调用“停止录制”工具栏

返回

Sub 录制宏时调用停止录制工具栏()

Application.CommandBars(\"Stop Recording\").Visible = TrueEnd Sub▲高级筛选5列不重复数据至指定表

返回

Sub 高级筛选5列不重复数据至Sheet2()

Sheets(\"Sheet2\").Range(\"A1:E65536\") = \"\" '清除Sheet2的A:D列

1/144

Range(\"A1:E65536\").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _ \"A1\"), Unique:=True

Sheet2.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 Sub Select Case Target.Address Case \"$A$4\" Call 宏1

Cancel = True Case \"$B$4\" Call 宏2

Cancel = True Case \"$C$4\" Call 宏3

Cancel = True Case \"$E$4\" Call 宏4 Cancel = True End SelectEnd Sub

▲双击指定区域单元执行宏(工作表代码)返回

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\打开隐藏表End Sub▲进入单元执行宏(工作表代码)

返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)

2/144

'以单元格进入代替按钮对象调用宏

If Range(\"$A$1\") = \"关闭\" Then Exit Sub Select Case Target.Address

Case \"$A$5\" '单元地址(Target.Address),或命名单元名字(Target.Name) Call 宏1 Case \"$B$5\" Call 宏2 Case \"$C$5\" Call 宏3 End SelectEnd Sub

▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range(\"$A$1\") = \"关闭\" Then Exit Sub

If Not Application.Intersect(Target, Range(\"A4:A9\打开隐藏表End Sub▲在多个宏中依次循环执行一个（控件按钮代码）

返回

Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0 宏1

RunMacro = 1Case 1 宏2

RunMacro = 2Case 2 宏3

RunMacro = 0End SelectEnd Sub

3/144

▲在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）

返回

Private Sub CommandButton1_Click()With CommandButton1

If .Caption = \"保护工作表\" Then Call 保护工作表

.Caption = \"取消工作表保护\" Exit Sub End If

If .Caption = \"取消工作表保护\" Then Call 取消工作表保护

.Caption = \"保护工作表\" Exit Sub End IfEnd WithEnd Sub▲在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）

返回

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 Sub End If

If .Caption = \"宏3\" Then Call 宏3

.Caption = \"宏1\" Exit Sub

4/144

End IfEnd WithEnd Sub

▲根据A1单元文本隐藏/显示按钮（控件按钮代码）

返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range(\"A1\") > 2 ThenCommandButton1.Visible = 1Else

CommandButton1.Visible = 0End IfEnd Sub

Private 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 2

5/144

ActiveSheet.PrintOut from:=i, To:=i Next i

MsgBox \"现在打印偶数页,按确定开始.\" For i = 2 To Ps Step 2

ActiveSheet.PrintOut from:=i, To:=i Next iEnd Sub

▲自动打印多工作表第一页

返回Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syz

x = InputBox(\"请输入起始工作表名字:\")sy = InputBox(\"请输入结束工作表名字:\")y = Sheets(x).Indexsyz = Sheets(sy).Index For sh = y To syz Sheets(sh).Select

Sheets(sh).PrintOut from:=1, To:=1 Next shEnd Sub

▲查找A列文本循环插入分页符

返回

Sub 循环插入分页符()

' Selection = Workbooks(\"临时表\").Sheets(\"表2\").Range(\"A1\") 调用指定地址内容

Dim i As Long

Dim times As Long

times = Application.WorksheetFunction.CountIf(Sheet1.Range(\"a:a\"), \"分页\") 'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于21474837) For i = 1 To times

6/144

Call 插入分页符 Next iEnd Sub

Sub 插入分页符()

Cells.Find(What:=\"分页\

xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _ .Activate

ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd Sub

Sub 取消原分页() Cells.Select

ActiveSheet.ResetAllPageBreaksEnd Sub

▲将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 Then Pic.Top = Pic.TopLeftCell.Top Pic.Left = Pic.TopLeftCell.Left Pic.Height = Pic.TopLeftCell.Height Pic.Width = Pic.TopLeftCell.Width End If NextEnd Sub▲返回光标所在行数

返回

Sub 返回光标所在行数()x = ActiveCell.Row Range(\"A1\") = x

7/144

End 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(\"*\MsgBox nEnd Sub▲返回A列数据的最大行数

返回

Sub 返回A列数据的最大行数()

n = Range(\"a65536\").End(xlUp).RowRange(\"B1\") = nEnd Sub▲将所选区域文本插入新建文本框

返回8/144

Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)Next

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + ActiveCell. Selection.Characters.Text = \"问题：\" & n

With Selection.Characters(Start:=1, Length:=3).Font .Name = \"黑体\"

.FontStyle = \"常规\" .Size = 12 End WithEnd Sub

▲批量插入地址批注

返回Sub 批量插入地址批注()On Error Resume NextDim r As Range

If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.Comment.Deleter.AddComment

r.Comment.Visible = False

r.Comment.Text Text:=\"本单元格：\" & r.Address & \" of \" & Selection.AddressNextEnd IfEnd Sub▲批量插入统一批注

返回

Sub 批量插入统一批注()

Dim r As Range, msg As String

msg = InputBox(\"请输入欲批量插入的批注\If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddComment

9/144

r.Comment.Visible = Falser.Comment.Text Text:=msgNextEnd IfEnd Sub

▲以A1单元内容批量插入批注

返回Sub 以A1单元内容批量插入批注()Dim r As Range

If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddComment

r.Comment.Visible = False

r.Comment.Text Text:=[a1].TextNextEnd IfEnd Sub

▲不连续区域插入当前文件名和表名及地址返回

Sub 批量插入当前文件名和表名及地址() For Each mycell In Selection

mycell.FormulaR1C1 = \"[\" + ActiveWorkbook.Name + \"]\" + ActiveSheet.Name + \"!\" + mycell.Address NextEnd Sub▲不连续区域录入当前单元地址

返回

Sub 区域录入当前单元地址()

For Each mycell In Selection

mycell.FormulaR1C1 = mycell.Address NextEnd Sub▲连续区域录入当前单元地址

返回Sub 连续区域录入当前单元地址()

10/144

Selection = \"=ADDRESS(ROW(),COLUMN(),4,1)\" Selection.Copy

Selection.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 批量录入当前文件名()

11/144

Selection.FormulaR1C1 = ThisWorkbook.NameEnd Sub

▲不连续区域添加文本

返回Sub 批量添加文本()Dim s As Range

For Each s In Selections = s & \"文本内容\"NextEnd Sub▲不连续区域插入文本

返回Sub 批量插入文本()Dim s As Range

For Each s In Selections = \"文本内容\" & sNextEnd Sub

▲从指定位置向下同时录入多单元指定内容

返回

Sub 从指定位置向下同时录入多单元指定内容()Dim arr

arr = Array(\"1\

[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub▲按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)

12/144

Sheets(str1).Select

Sheets(str1).Move after:=Sheets(I) I = I + 1

Sheets(\"aa\").Select LoopEnd Sub

▲以A1单元文本作表名插入工作表

返回Sub 以A1单元文本作表名插入工作表() Dim nm As String nm = [a1] Sheets.Add

ActiveSheet.Name = nmEnd Sub

▲删除全部未选定工作表

返回

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.SelectedSheets ShtName(n) = sht.Name n = n + 1 Next

Application.DisplayAlerts = False For Each sht In Sheets iFlag = False

For i = 1 To n - 1

If ShtName(i) = sht.Name Then iFlag = True Exit For

13/144

End If Next

If Not iFlag Then sht.Delete Next

Application.DisplayAlerts = TrueEnd Sub

▲工作表标签排序

返回Sub 工作表标签排序()

Dim i As Long, j As Long, nums As Long, msg As Long

msg = MsgBox(\"工作表按升序排列请选 '是[Y]'. \" & vbCrLf & vbCrLf & \"工作表按降序排列请选 '否[N]'\If msg = vbCancel Then Exit Subnums = Sheets.Count

If msg = vbYes Then 'Sort ascending For i = 1 To nums For j = i To nums

If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then Sheets(j).Move Before:=Sheets(i) End If Next j Next i

Else 'Sort descending For i = 1 To nums

For j = i To nums

If UCase(Sheets(j).Name) > UCase(Sheets(i).Name) Then Sheets(j).Move Before:=Sheets(i) End If Next j Next i End If

14/144

End Sub

▲定义指定工作表标签颜色

返回

Sub 定义指定工作表标签颜色()

Sheets(\"Sheet1\").Tab.ColorIndex = 46End Sub

▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As Range On Error Resume Next Sheets(\"目录\").Activate If Err = 0 Then

Sheets(\"目录\").UsedRange.Delete Else

Sheets.Add

ActiveSheet.Name = \"目录\" End If

For i = 1 To Sheets.Count

If Sheets(i).Name <> \"目录\" Then s = s + 1

Set Rng = Sheets(\"目录\").Cells(((s - 1) Mod 20) + 1, (s - 1) \\ 20 + 1 + 1) Rng = Format(s, \" 0\") & \". \" & Sheets(i).Name

ActiveSheet.Hyperlinks.Add Rng, \"#\" & Sheets(i).Name & \"!A1\ End If Next

Sheets(\"目录\").Range(\"b:iv\").EntireColumn.ColumnWidth = 20End Sub▲建立工作表文本目录

返回Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)

15/144

Sheets(1).Name = \"目录\"For i = 2 To Sheets.Count

Cells(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 Worksheet

Application.ScreenUpdating = False

Workbooks.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) = sh.Name '将表名称返回到第1列i = i + 1 '返回每个表名称向下移动1行Next sh

Windows(\"2.xls\").Close '关闭对象文件Application.ScreenUpdating = TrueEnd Sub

▲当前单元录入计算机名

返回Sub 当前单元录入计算机名()

Selection = Environ(\"COMPUTERNAME\")

'Selection = Workbooks(\"临时表\").Sheets(\"表2\").Range(\"A1\") 调用指定地址内容 End Sub

16/144

▲当前单元录入计算机用户名

返回

Sub 当前单元录入计算机用户名() Selection = Environ(\"Username\")

'Selection = Workbooks(\"临时表\").Sheets(\"表2\").Range(\"A1\") 调用指定地址内容 End Sub▲解除全部工作表保护

返回Sub 解除全部工作表保护()Dim n As Integer

    For n = 1 To Sheets.Count        Sheets(n).Unprotect    Next 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 \"密码错误,按确定退出!\Exit SubEnd If

Cells(1, 1) = 10End Sub

17/144

Sub 执行前需要验证密码的宏()

If InputBox(\"请输入您的使用权限:\重排窗口 '要执行的宏代码或宏名称Else

MsgBox \"对不起,您没有使用该宏的权限,按确定键后退出!\"End IfEnd Sub

▲拷贝A1公式和格式到A2

返回Sub 拷贝A1公式到A2()

Workbooks(\"临时表\").Sheets(\"表1\").Range(\"A1\").Copy

Workbooks(\"临时表\").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.Delete

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:=\"70\"

Selection.FormatConditions(1).Interior.ColorIndex = 45

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _ Formula1:=\"55\"

Selection.FormatConditions(2).Interior.ColorIndex = 39

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:=\"60\"

Selection.FormatConditions(3).Interior.ColorIndex = 34

18/144

End Sub

▲插入透明批注

返回

Sub 插入透明批注()

Selection.AddComment

Selection.Comment.Visible = False

Dim XS As Worksheet

For i = 1 To ActiveSheet.Comments.Count ActiveSheet.Comments(i).Text \"透明批注\"

ActiveSheet.Comments(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).Row Sheets(\"数据库\").Select Range(\"A\" & a + 1).SelectEnd Sub▲定位选定单元格式相同的全部单元格

返回

Sub 定位选定单元格式相同的全部单元格()

Dim FirstCell As Range, FoundCell As Range Dim AllCells As Range

With Application.FindFormat .Clear

19/144

.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.Name = Selection.Font.Name

.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.FormulaHidden End With

Set FirstCell = ActiveSheet.UsedRange.Find(what:=\"\ If FirstCell Is Nothing Then Exit Sub End If

Set AllCells = FirstCell Set FoundCell = FirstCell Do

Set FoundCell = ActiveSheet.UsedRange.Find(After:=FoundCell, what:=\"\ If FoundCell Is Nothing Then Exit Do Set AllCells = Union(FoundCell, AllCells)

If FoundCell.Address = FirstCell.Address Then Exit Do

20/144

Loop AllCells.SelectEnd Sub

▲按当前单元文本定位

返回Sub 按当前单元文本定位()

ABC = Selection

Dim aa As Range

For Each a In ActiveSheet.UsedRangeIf a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElse

Set aa = Union(aa, a.Cells)End IfEnd IfNext

aa.SelectEnd Sub

▲按固定文本定位

返回Sub 文本定位()Dim aa As Range

For Each a In ActiveSheet.UsedRangeIf a Like \"*合计*\" ThenIf aa Is Nothing ThenSet aa = a.CellsElse

Set aa = Union(aa, a.Cells)End IfEnd IfNext

21/144

aa.SelectEnd Sub

▲删除包含固定文本单元的行或列

返回Sub 删除包含固定文本单元的行或列() Do

Cells.Find(what:=\"哈哈\").Activate

Selection.EntireRow.Delete '删除行' Selection.EntireColumn.Delete '删除列

Loop Until Cells.Find(what:=\"哈哈\") Is NothingEnd Sub▲定位数据及区域以上的空值

返回Sub 定位数据及区域以上的空值()Dim aa As Range

For Each a In ActiveSheet.UsedRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElse

Set aa = Union(aa, a.Cells)End IfEnd IfNext

aa.SelectEnd Sub

▲右侧单元自动加5(工作表代码)

返回

Private Sub Worksheet_Change(ByVal Target As Range)Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd Sub

22/144

▲当前单元加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 23

Cells(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 2

If Not Application.Intersect(T, a(i)) Is Nothing Then [a1].Select: Exit For End If NextEnd Sub▲将A1单元录入的数据累加到B1单元（工作表代码）

返回

Private Sub Worksheet_Change(ByVal Target As Range)Dim t As Long

If Target.Address = \"$A$1\" Thent = Sheet1.Range(\"$B$1\").Value

Sheet1.Range(\"$B$1\").Value = t + Target.ValueEnd IfEnd Sub

▲在指定颜色区域选择单元时添加/取消\"√\"（工作表代码）

返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)

23/144

Dim myrg As Range

For Each myrg In Target

If myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> \"√\ NextEnd Sub

▲在指定区域选择单元时添加/取消\"√\"（工作表代码）

返回Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As Range

If Target.Count <= 15 Then

If Not Application.Intersect(Target, Range(\"D6:D20\")) Is Nothing Then For Each Rng In Selection With Rng

If .Value = \"\" Then .Value = \"√\" Else

.Value = \"\" End If End With Next End If End IfEnd Sub▲双击指定单元，循环录入文本（工作表代码）

返回

Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)If T.Address <> \"$A$1\" Then Exit SubCancel = True

T = IIf(T = \"好\End Sub

双击指定单元，循环录入文本（工作表代码）Dim nums As Byte

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

24/144

If Target.Address = \"$A$1\" Thennums = nums Mod 3 + 1

Target = Mid(\"上中下\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 Then Target = Val(Target) + 1 End 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 Then oldvalue = Val(Target.Value)

inputvalue = InputBox(\"请输入数量,按ENTER键确认!\ Target.Value = oldvalue + inputvalue End IfEnd Sub▲选择单元区域触发事件（工作表代码）

返回25/144

Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = \"$A$1:$B$2\" Then MsgBox \"你选择了$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 = 2

Rows(\"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 = xlNone

26/144

Rows(Target.Row).Interior.ColorIndex = 34

Columns(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 Next

y = Int(Round(100 * Abs(M)) / 100)

j = Round(100 * Abs(M) + 0.00001) - y * 100 f = (j / 10 - Int(j / 10)) * 10

A = IIf(y < 1, \"\

b = IIf(j > 9.5, Application.Text(Int(j / 10), \"[DBNum2]\") & \"角\ c = IIf(f < 1, \"整\ M = IIf(Abs(M) < 0.005, \"\End Sub▲将全部工作表的A1单元作为单击按钮（工作簿代码）返回

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)If Target.Address = \"$A$1\" Then Call 宏名End IfEnd Sub▲闹钟——到指定时间执行宏（工作簿代码）

返回27/144

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 Sub

Public Sub Worksheet_Change(ByVal Target As Range)

If Not Application.Intersect(Target, [A1:A1000]) Is Nothing Then

28/144

If Target.Column = 1 Then

Target.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列为指定内容的行()

29/144

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 NextEnd Sub

▲删除A列非数字单元行

返回Sub 删除A列非数字单元行()i = [a65536].End(xlUp).Row

Range(\"A1:A\" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.DeleteEnd Sub▲有条件删除当前行

返回

Sub 有条件删除当前行()

If [A1] = 2 Or [B1] = \"删除\" Then Selection.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(\"*\ Rows(\"5:\" & i).SelectEnd Sub

30/144

Sub 选择第5行开始所有数据行B()

Rows(\"5:\" & Cells.Find(\"*\End 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列

返回

31/144

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 = False

Dim raddress As String, taddress As Stringraddress = Selection.Address

taddress = ActiveSheet.UsedRange.AddressWith Sheets.Add

.Range(taddress) = 0.Range(raddress) = \"=0\"

raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address.DeleteEnd With

ActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub▲调整选中对象中的文字

返回

Sub 调整选中对象中的文字()'文字居中、自动调整大小 With Selection

.HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ReadingOrder = xlContext .Orientation = xlHorizontal

32/144

.AutoSize = True .AddIndent = False End WithEnd Sub

▲去除指定范围内的对象返回Sub 去除指定范围内的对象()  Dim p As Shape

    Set My = Worksheets(\"工作表名\")    For Each p In My.Shapes

        If Not Application.Intersect(p.TopLeftCell, Range(\"范围\")) Is Nothing Then p.Delete    NextEnd Sub▲更新透视表数据项

返回

Sub DeleteMissingItems2002All()'防止数据透视表中显示无用的数据项'在 Excel 2002 或更高版本中'如果无用的数据项已经存在, '运行这个宏可以更新Dim pt As PivotTableDim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets For Each pt In ws.PivotTables

pt.PivotCache.MissingItemsLimit = xlMissingItemsNone Next ptNext wsEnd Sub ▲将全部工作表名称写到A列

返回

Sub 将全部表名称写到A列()k = 1

For Each Sht In Sheets

Cells(k + 1, 1) = Sht.Name '指定写入的行和列

33/144

k = k + 1NextEnd Sub

▲为当前选定的多单元插入指定名称返回Sub 为当前选定的多单元插入指定名称() Selection.Name = \"临时\"

ActiveWorkbook.Names.Add Name:=\"临时\End Sub▲删除全部名称

返回Sub 删除全部名称()On Error Resume NextDim l As Integer

l = ActiveWorkbook.Names.CountFor i = l To 1 Step -1

ActiveWorkbook.Names(i).DeleteNextEnd Sub

▲以指定区域为表目录补充新表

返回

Sub 以指定区域为表目录补充新表()Dim dic As Object, sh As WorksheetDim arr, item

arr = Range(\"B1:BB1\")

Set dic = CreateObject(\"scripting.dictionary\") For Each sh In ThisWorkbook.Worksheets dic.Add sh.Name, \"\" Next

For Each item In arr

If item <> \"\" And Not dic.exists(Trim(item)) Then With ThisWorkbook.Worksheets.Add .Name = item End With

34/144

End If Next

Set dic = NothingEnd Sub

▲按A列数据批量修改表名称

返回Sub 按A列数据批量修改表名称() Dim i%

For i = 1 To Sheets.Count - 1

Sheets(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.Count

If Cells(i, 1) = Sheets(j).Name ThenExit ForEnd IfNext

Sheets.Add(after:=Sheets(Sheets.Count)).Name = Cells(i, 1)NextEnd Sub▲清除剪贴板

返回

Sub 清除剪贴板()

Application.CutCopyMode = False

Application.CommandBars(\"Task Pane\").Visible = FalseEnd Sub▲批量清除软回车

返回35/144

Sub 批量清除软回车()

'也可直接使用Alt+10或13替换

Cells.Replace What:=Chr(10), Replacement:=\"\ xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=FalseEnd Sub

▲判断指定文件是否已经打开

返回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▲当前文件另存到指定目录

返回

Sub 当前激活文件另存到指定目录()

ActiveWorkbook.SaveAs Filename:=\"E:\\信件\\\" & ActiveWorkbook.NameEnd Sub▲另存指定文件名

返回

Sub 另存指定文件名()

ActiveWorkbook.SaveAs ThisWorkbook.Path & \"\\别名.xls\"End Sub

▲以本工作表名称另存文件到当前目录返回

Sub 以本工作表名称另存文件到当前目录()

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & \"\\\" & ActiveSheet.Name & \".xls\"End Sub▲将本工作表单独另存文件到Excel当前默认目录

返回36/144

Sub 将本工作表单独另存文件到Excel当前默认目录()ActiveSheet.Copy

ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & \".xls\"End Sub

▲以活动工作表名称另存文件到Excel当前默认目录返回Sub 以活动工作表名称另存文件到Excel当前默认目录()

ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & \".xls\

xlNormal, Password:=\"\ , CreateBackup:=FalseEnd Sub

▲另存所有工作表为工作簿返回Sub 另存所有工作表为工作簿()Dim sht As Worksheet

Application.ScreenUpdating = Falseipath = ThisWorkbook.Path & \"\\\"For Each sht In Sheets sht.Copy

ActiveWorkbook.SaveAs ipath & sht.Name & \".xls\" '(工作表名称为文件名）

'ActiveWorkbook.SaveAs ipath & sht.Name & Trim(sht.[d15]) & \".xls\" '（文件名称 & D15单元内容） 'ActiveWorkbook.SaveAs ipath & Trim(sht.[d15]) & \".xls\" '（文件名称为D15单元内容） ActiveWorkbook.CloseNext

Application.ScreenUpdating = TrueEnd Sub▲以指定单元内容为新文件名另存文件

返回

Sub 以指定单元内容为新文件名另存文件()

ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & \"\\\" & Sheet1.[A1]End Sub

▲以当前日期为新文件名另存文件

返回Sub 以当前日期为新文件名另存文件()

ThisWorkbook.SaveAs ThisWorkbook.Path & \"\\\" & Format(Now(), \"yyyymmdd\") & \".xls\"

37/144

End Sub

Sub 以当前日期为名称另存文件()

ActiveWorkbook.SaveAs Filename:=Date & \".xls\"End Sub

▲以当前日期和时间为新文件名另存文件返回Sub 以当前日期和时间为新文件名另存文件()

ThisWorkbook.SaveAs ThisWorkbook.Path & \"\\\" & Format(Now(), \"yyyy\" & \"年\" & \"mm\" & \"月\" & \"dd\" & \"日\" & \"h\" & \"时\" & \"mm\" & \"分\"End Sub▲另存本表为TXT文件返回Sub 另存本表为TXT文件() Dim s As String

Dim FullName As String, rng As Range Application.ScreenUpdating = False

FullName = (ActiveSheet.Name & \".txt\") '以当前表名为TXT文件名

' FullName = Replace(ThisWorkbook.FullName, \".xls\ '以当前文件名为TXT文件名

' FullName = Replace(ThisWorkbook.FullName, \".xls\ '以文件名&表名为TXT文件名 Open FullName For Output As #1 '以读写方式打开文件，每次写内容都会覆盖原先的内容 '参考帮助，fullname为文件全名

For Each rng In Range(\"a1\").CurrentRegion s = s & IIf(s = \"\|\") & rng.Value

If rng.Column = Range(\"a1\").CurrentRegion.Columns.Count Then Print #1, s & \"|\" '把数据写到文本文件里 s = \"\" End If Next

Close #1 '关闭文件

Application.ScreenUpdating = True MsgBox \"数据已导入文本\"End Sub▲引用指定位置单元内容为部分文件名另存文件

返回38/144

Sub 引用指定位置单元内容为部分文件名另存文件()

ActiveWorkbook.SaveAs Filename:=\"E:\\信件\\\" & \"解答\" & Range(\"sheet1!a1\") & \"郎雀.xls\"End Sub

▲将A列数据排序到D列

返回Sub 将A列数据排序到D列()[d:d] = [a:a].Value

[d:d].Sort Key1:=Range(\"D1\"), Order1:=xlAscending, Header:=xlYesEnd Sub▲将指定范围的数据排列到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 + 1

arr2(i, 1) = xNext x

Range(\"D1\").Resize(i, 1) = arr2End Sub▲光标移动

返回

Sub 光标移动()

ActiveCell.Offset(1, 2).Select '向下移动1行，向右移动2列End Sub▲光标所在行上移一行

返回

Sub 光标所在行上移一行() Dim i%

i = Split(ActiveCell.Address, \"$\")(2) If i > 1 Then Rows(i).Cut

Rows(i - 1).Insert Shift:=xlDown

39/144

End IfEnd Sub

▲加数据有效

返回Sub 加数据有效()

With Selection.Validation .Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=\"bigsun010@sina.com\" .IgnoreBlank = False .InCellDropdown = False .InputTitle = \"\" .ErrorTitle = \"\" .InputMessage = \"\"

.ErrorMessage = \"要奋斗就会有牺牲，死人的事是经常发生的。\" .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End WithEnd Sub▲取消数据有效

返回

Sub 取消数据有效()

With Selection.Validation .Delete

.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween

.IgnoreBlank = False .InCellDropdown = False .InputTitle = \"\" .ErrorTitle = \"\" .InputMessage = \"\" .ErrorMessage = \"\"

.IMEMode = xlIMEModeNoControl

40/144

.ShowInput = True .ShowError = True End WithEnd Sub

▲重排窗口

返回Sub 重排窗口()

Application.CommandBars(\"Web\").Visible = False

Application.CommandBars(\"我的工具\").Visible = False Windows.Arrange ArrangeStyle:=xlCascadeEnd Sub▲按当前单元文本选择打开指定文件单元

返回Sub 选择打开文件单元() Dim a

a = ActiveCell.Value

Range(a).Worksheet.Activate Range(a).SelectEnd Sub

▲回车光标向右

返回

Sub 录入光标向右()

Application.MoveAfterReturnDirection = xlToRightEnd Sub▲回车光标向下

返回

Sub 录入光标向下()

Application.MoveAfterReturnDirection = xlDownEnd Sub

▲保护工作表时取消选定锁定单元

返回

Sub 取消选定锁定单元()

ActiveSheet.EnableSelection = xlUnlockedCells '用于2000版End Sub

41/144

▲保存并退出Excel

返回

Sub 保存并退出Excel()

Application.SendKeys (\"{ENTER}{ENTER}%fx\")ActiveWorkbook.SaveEnd Sub

▲隐藏/显示指定列空值行返回Sub 隐藏显示E列空值行()

Range(\"E1:E1000\").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = Not (Range(\"E1:E1000\").SpecialCells(xlCellTypeBlanks).EntireEnd Sub▲深度隐藏指定工作表

返回Sub 深度隐藏指定工作表()

Sheets(\"用户名密码\").Visible = xlVeryHiddenEnd Sub▲隐藏指定工作表

返回

Sub 隐藏指定工作表()

Sheets(\"用户名密码\").Visible = falseEnd Sub

▲隐藏当前工作表

返回

Sub 隐藏当前工作表()

ActiveWindow.SelectedSheets.Visible = falseEnd Sub▲返回当前工作表名称

返回

Sub 返回当前工作表名称()wsName = ActiveSheet.Name

MsgBox \"当前工作表为：\" & wsNameEnd Sub▲获取上一次所进入工作簿的工作表名称

返回42/144

Sub 获取上一次所进入工作簿的工作表名称()MsgBox Workbooks(2).ActiveSheet.NameEnd Sub

▲按光标选定颜色隐藏本列其他颜色行返回Sub 按颜色筛选() '思路就是:其它背景色之行全部隐藏

Dim UseRow, AC, i '首先选择一个有颜色之单元格，然后动行宏，其它颜色所在行隐藏

UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row 'SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格If ActiveCell.Row > UseRow Then

MsgBox \"请在要筛选的区域选择一个有颜色之单元格！\Else

AC = ActiveCell.Column

Cells.EntireRow.Hidden = False '显示所有行

For i = 2 To UseRow

If Cells(i, AC).Interior.ColorIndex <> ActiveCell.Interior.ColorIndex Then

Cells(i, AC).EntireRow.Hidden = True '如果2至已用行之单元格的有列之颜色不等于当前单元格颜色则隐藏整行 End If NextEnd IfEnd Sub▲打开工作簿自动隐藏录入表以外的其他表

返回

Private Sub Workbook_Open()Dim i

For i = 1 To Sheets.Count

If Sheets(i).Name <> \"录入\" ThenSheets(i).Visible = FalseEnd IfNextEnd Sub▲除最左边工作表外深度隐藏所有表

返回Sub 除最左边工作表外深度隐藏所有表()

43/144

For i = 2 To ThisWorkbook.Sheets.Count Sheets(i).Visible = xlSheetVeryHiddenNextEnd Sub

▲关闭文件时自动隐藏指定工作表(ThisWorkbook)

返回Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Unprotect

Sheets(\"Sheet2\").Visible = False Sheets(\"Sheet3\").Visible = False

ActiveWorkbook.Protect Structure:=True, Windows:=FalseEnd Sub▲打开文件时提示指定工作表是保护状态(ThisWorkbook)

返回Private Sub Workbook_Open()

If Worksheets(\"Sheet1\").ProtectContents = True Then MsgBox \" Sheet1 保护了.\"End IfEnd Sub▲插入10行

返回

Sub 插入10行()

Rows(ActiveCell.Row & \":\" & ActiveCell.Row + 9).Select Selection.Insert Shift:=xlDownEnd Sub▲全选固定范围内小于0的单元

返回

Sub 全选固定范围内小于0的单元()Dim rng As RangeDim yvhf

For Each rng In Range(\"d6: i18\")If rng < 0 Then

yvhf = yvhf & rng.Address & \End If

44/144

Next

Range(Left(yvhf, Len(yvhf) - 1)).SelectEnd Sub

▲全选选定范围内小于0的单元

返回Sub 全选选定范围内小于0的单元()Dim rng As RangeDim yvhf

For Each rng In SelectionIf rng < 0 Then

yvhf = yvhf & rng.Address & \End IfNext

Range(Left(yvhf, Len(yvhf) - 1)).SelectEnd Sub

▲固定区域单元分类变色

#N/A

Sub 单元分类变色()Dim rng As Range

For Each rng In Range(\"d6: i18\")If rng < 0 Then

rng.Interior.ColorIndex = 4 '小于0的单元变绿底色End IfNext

For Each rng In Range(\"d6: i18\")If rng > 0 Then

rng.Interior.ColorIndex = 3 '文本、假空和大于0的单元变红底色End IfNext

For Each rng In Range(\"d6: i18\")

45/144

If rng = 0 Then

rng.Interior.ColorIndex = 2 '空值和等于0的单元变白底色End IfNextEnd Sub

▲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)) > 0 Then rg.Characters(i).Font.ColorIndex = 3    Next  Next

  Application.ScreenUpdating = TrueEnd Sub▲单元格录入数据时运行宏的代码

返回

Private Sub Worksheet_Change(ByVal Target As Range)重排窗口End Sub

▲焦点到A列时运行宏的代码

返回

Private Sub Worksheet_SelectionChange(ByVal Target As Range)    If Target.Column = 1 Then宏名

    End IfEnd Sub▲根据B列最后数据快速合并A列单元格的控件代码

返回Private Sub CommandButton1_Click()For i = 1 To [b65536].End(xlUp).Row

46/144

For j = i + 1 To [b65536].End(xlUp).Row If Range(\"a\" & j) = \"\" Then

Range(\"a\" & i & \":a\" & j).Merge Else Exit For End If Next jNext iEnd Sub

▲在F1单元显示光标位置批注内容的代码

返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)a = Selection.Addressb = Range(a).NoteTextCells(1, 6) = bEnd Sub▲显示光标所在单元的批注的代码

返回

Dim r As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)On Error Resume Next

r.Comment.Visible = FalseSet r = Target

r.Comment.Visible = TrueEnd Sub▲使单元内容保持不变的工作表代码

返回

Private Sub Worksheet_Change(ByVal Target As Range)[B2] = \"不可更改的数据\"End Sub▲有条件执行宏

返回Sub 高级筛选()

47/144

If [J1] = 2 Or [K1] = \"筛选\" Then Columns(\"D:E\").Select Selection.Clear Range(\"D1\").Select

Columns(\"A:B\").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _ \"G1:G2\"), CopyToRange:=Range(\"D1\"), Unique:=FalseEnd IfEnd Sub

▲有条件执行不同的宏

返回Sub 有条件执行不同的宏() If [b1].Value = \"A\" Then Application.Run \"宏1\"

ElseIf [b1].Value = \"B\" Then Application.Run \"宏2\"End IfEnd Sub

▲提示确定或取消执行宏

返回

Sub 提示确定或取消执行宏()

If vbOK = MsgBox(\"确定要复制吗?\Range(\"A4:A14\").Copy Range(\"b4:b14\")Msgbox \"复制结束\"End IfEnd Sub▲提示开始和结束

返回

 Sub 提示结束()Msgbox \"运行开始\"

 过程„„Msgbox \"运行结束\"End Sub

48/144

▲拷贝指定表不相邻多列数据到新位置

返回

Sub 拷贝指定表不相邻多列数据到新位置()

Sheets(\"sheet1\").Range(\"A:A,J:J\").Copy Range(\"d1\")End Sub▲选择2至4行

返回Sub 选择2至4行() Dim a As Integer Dim b As Integer a = 2 b = 4

Rows(a & \":\" & b).SelectEnd Sub

▲在当前选区有条件替换数值为文本

返回

Sub 在当前选区有条件替换数值为文本()For Each r In Selection

If r.Value > 18 And r.Value < 29.5 Then r.Value = \"Y\"NextEnd Sub▲自动筛选全部显示指定列

返回

Sub 自动筛选全部显示指定列()Selection.AutoFilter Field:=1Selection.AutoFilter Field:=2Selection.AutoFilter Field:=3Selection.AutoFilter Field:=4Selection.AutoFilter Field:=5Selection.AutoFilter Field:=6End Sub▲自动筛选第2列值为A的行

返回Sub 自动筛选第2列值为A的行()

49/144

[a1].AutoFilter 2, \"a\"End Sub

▲取消自动筛选()

返回Sub 取消自动筛选()

ActiveSheet.AutoFilterMode = False End Sub▲全部显示指定表的自动筛选

返回Sub 全部显示指定表的自动筛选()If Sheet1.FilterMode = True Then Sheet1.ShowAllDataEnd IfEnd Sub

▲强行合并单元

返回

Sub 强行合并单元()

Application.DisplayAlerts = False '不出现对话框，按对话框默认选择 Range(\"a3:a4\").Merge

Application.ScreenUpdating = TrueEnd Sub▲设置单元区域格式

返回

Sub 设置单元区域格式()

[a:a].NumberFormat = \"yyyy.mm.dd\"

Sheet2.[B:B].NumberFormatLocal = \"yyyy-m-d\" Sheet2.[C:C].NumberFormatLocal = \"G/通用格式\"End Sub

▲在所有工作表的A1单元返回顺序号

返回

Sub 在所有工作表的A1单元返回顺序号()For i = 1 To Sheets.Count

Sheets(i).Cells(1, 1) = \"'\" & Application.WorksheetFunction.Text(0 + i, \"000\")Next

50/144

End Sub

▲根据A1单元内容返回C1数值

返回

Sub 根据A1单元内容返回C1数值()If Range(\"A1\") = \"A\" Then

Range(\"C1\").FormulaR1C1 = \"结算\" ElseIf Range(\"A1\") = \"B\" Then

Range(\"C1\").FormulaR1C1 = \"合计\" ElseIf Range(\"A1\") = \"C\" Then Range(\"C1\").FormulaR1C1 = \"部门\" End IfEnd Sub▲根据A1内容选择执行宏

返回Sub 根据A1内容选择执行宏() Select Case Sheet1.[A1] Case \"A\" 宏1 Case \"B\" 宏2 Case \"C\" 宏3 Case Else End SelectEnd Sub

▲删除A列空行

返回

Sub 删除A列空行()

Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.DeleteEnd Sub▲在A列产生不重复随机数

返回Sub 在A列产生不重复随机数() Randomize Timer

51/144

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 = k - 1 l = l + 1

Cells(l, 1) = aaLoopEnd Sub

▲将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▲取消选定区域的公式只保留值(假空转真空)

返回

Sub 取消选定区域的公式只保留值()

 '   Sheets(\"数据归并集中\").Select '指定工作表 '   Columns(\"Q:R\").Select '指定范围Selection.Value = Selection.ValueEnd Sub

52/144

▲处理导入的显示为科学计数法样式的身份证号

返回

Sub 处理导入的显示为科学计数法样式的身份证号()Selection.Value = Selection.FormulaEnd Sub▲返回指定单元的行高和列宽

返回Sub 返回指定单元的行高和列宽()

[c2] = Range(\"A1\").ColumnWidth '列宽[b2] = Range(\"A1\").RowHeight '行高End Sub

Sub 返回指定单元的行高和列宽() Dim r%, c%

r = [a1].RowHeight c = [a1].ColumnWidth [b2] = r '行高 [c2] = c '列宽End Sub

▲指定行高和列宽

返回

Sub 指定行高和列宽()

Range(\"A1:F1\").ColumnWidth = 10 '指定列宽 Range(\"A2:A10\").RowHeight = 40 '指定行高End Sub

Sub 指定行高和列宽()

Columns(\"A:F\").ColumnWidth = 10 '指定列宽 Rows(\"2:10\").RowHeight = 40 '指定行高End Sub

▲指定单元的行高和列宽与A1单元相同

返回

Sub 指定单元的行高和列宽与A1单元相同()

Range(\"A1:F1\").ColumnWidth = Range(\"A1\").ColumnWidth '指定列宽 Range(\"A2:A10\").RowHeight = Range(\"A1\").RowHeight '指定行高

53/144

End Sub

▲填公式

返回

Sub 填公式()

Range(\"C2:C12\").Value = \"=SUM(A2:B2)\"End Sub▲建立当前工作表的副本为001表

返回Sub 建立当前工作表的副本为001表()

ActiveSheet.Copy Before:=Sheets(1) ActiveSheet.Name = \"001\"End Sub▲在第一个表前插入多工作表

返回Sub 在第一个表前插入多工作表()Sheets(1).SelectFor I = 1 To 50

Sheets.Add.Name = \"新表\" & INextEnd Sub▲清除A列再插入序号

返回

Sub 清除A列再插入序号()

'Columns(1).ClearContents '清除A列内容For i = 1 To 20Range(\"a\" & i) = iNextEnd Sub▲反方向文本(自定义函数)

返回

Function zhyz(zhyz1 As Range)zhyz = StrReverse(zhyz1)End Function

将代码复制到模块后单元公式：=zhyz(单元格)

54/144

▲指定选择单元区域弹出消息

返回

Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = \"$A$1:$C$3\" Then MsgBox \"你选择对了\"End IfEnd Sub

▲将B列数据添加超链接到K列返回Sub 将B列数据添加超链接到K列()

For Each Rng In Range(\"B3:B\" & [B65536].End(xlUp).Row)

ActiveSheet.Hyperlinks.Add Anchor:=Rng, Address:=\"\ NextEnd Sub▲删除B列数据的超链接

返回

Sub 删除超链接()

For Each Rng In Range(\"B3:B\" & [B65536].End(xlUp).Row) Sheet1.Range(Rng.Address).Hyperlinks.Delete NextEnd Sub

▲分离临时表A列数据的文本和超链接并整理到数据库表返回

Sub 分离A列中的超链接到指定表的B和C列()

i = Worksheets(\"数据库\").Range(\"b60000\").End(xlUp).RowFor Each h In Worksheets(\"临时\").Hyperlinks

Worksheets(\"数据库\").Cells(i + 1, 2) = h.TextToDisplayWorksheets(\"数据库\").Cells(i + 1, 3) = h.Address

Range(Worksheets(\"数据库\").Cells(i + 1, 3), Worksheets(\"数据库\").Cells(i + 1, 3)).Hyperlinks.Add Anchor:=Cells(i + 1, 3), Addresi = i + 1NextEnd Sub▲分离临时表A列数据的文本和超链接并会同其他数据整理到数据库表

返回55/144

Sub 分离A列数据的文本和超链接并会同其他数据整理到指定表() ier = Worksheets(\"数据库\").Range(\"b60000\").End(xlUp).RowFor ee = 5 To Range(\"a60000\").End(xlUp).RowFor Each hh In Worksheets(\"临时\").Hyperlinks

If hh.TextToDisplay = Cells(ee, 1) And Cells(ee, 1) <> \"\" Thenwww = www & \ End IfNextNext

www = Right(www, Len(www) - 1)zxc = Split(www, \

For sd = 0 To UBound(zxc) - 1

For wee = zxc(sd) + 1 To zxc(sd + 1) - 1

Worksheets(\"数据库\").Cells(sdf + ier + 1, uu + 4) = Cells(wee, 1) uu = uu + 1 Next

sdf = sdf + 1 uu = 0 Next

For Each hhh In Worksheets(\"临时\").Range(\"A6:A6000\").HyperlinksWorksheets(\"数据库\").Cells(ier + 1, 2) = hhh.TextToDisplayWorksheets(\"数据库\").Cells(ier + 1, 3) = hhh.Address

Range(Worksheets(\"数据库\").Cells(ier + 1, 3), Worksheets(\"数据库\").Cells(ier + 1, 3)).Hyperlinks.Add Anchor:=Worksheets(\"数据库\"ier = ier + 1NextEnd Sub

▲返回A列最后一个非空单元行号

返回

Sub 返回A列最后非空单元行号()

MsgBox Cells.Range(\"A65536\").End(xlUp).RowEnd Sub▲返回表中第一个非空单元地址(行搜索)

返回Sub 返回表中第一个非空单元地址()

56/144

MsgBox Cells.Find(\"*\").AddressEnd Sub

▲返回表中各非空单元区域地址(行搜索)

返回Sub 返回表中各非空单元区域地址()

MsgBox Cells.SpecialCells(2).AddressEnd Sub▲返回第一个数值行号

返回Sub 返回第一个数值行号()

MsgBox [b:b].SpecialCells(2, 1).RowEnd Sub▲返回第1行最右边非空单元的列号

返回Sub 返回第1行最右边非空单元的列号()X = [IV1].End(xlToLeft).ColumnMsgBox XEnd Sub▲返回连续数值单元的数量

返回

Sub 返回连续数值单元的数量()

MsgBox [b:b].SpecialCells(2, 1).Rows.CountEnd Sub

▲统计指定范围和内容的单元数量

返回

Sub 统计指定范围和内容的单元数量()

x = Application.WorksheetFunction.CountIf(Range(\"A3:B100\"), \"总计\")Range(\"B1\") = xEnd Sub▲统计不同颜色的数字的和（自定义函数）

返回

Public Function COLOR(ByVal X As Range, Y)For Each I In X

If I.Font.ColorIndex = Y Then

57/144

COLOR = COLOR + I End IfNext I

End Function

'统计红色,输入：=COLOR(B2:B8,3)'统计蓝色,输入：=COLOR(B2:B8,5)

▲返回非空单元数量

返回Sub 返回非空单元数量()

x = Application.CountA(Range(\"A1:Z65536\"))MsgBox xEnd Sub▲返回A列非空单元数量

返回

Sub 返回A列非空单元数量()

y = Application.CountA(Columns(1))MsgBox yEnd Sub▲返回圆周率π

返回

Sub Macro1()

Range(\"A1\") = Application.Pi()End Sub

▲定义指定单元内容为页眉/页脚

返回

Sub 定义指定单元内容为页眉/页脚()BBB = Sheets(\"表1\").Range(\"A2\") With ActiveSheet.PageSetup

.CenterHeader = BBB '定义页眉 ' .CenterFooter = BBB '定义页脚 End WithEnd Sub

58/144

▲提示并全部清除当前选择区域返回

Sub 提示并全部清除当前选择区域()

If MsgBox(\"你确定要清除选择的区域吗?\End Sub▲全部清除当前选择区域

返回Sub 全部清除当前选择区域()Selection.Clear

' Range(\"A1:B10\").Clear '全部清除指定区域End Sub▲清除指定区域数值

返回Sub 清除单元数值()

Sheet1.[A1:A10].ClearContentsEnd Sub

Sub 清除指定区域数值()

Range(\"A1:C8\") = ClearContentsEnd Sub

Sub 清除指定区域数值() Sheet1.[A1:A10]=\"\"End Sub

▲对指定工作表执行取消隐藏》打印》隐藏工作表

返回Sub 打印隐藏工作表()

Sheets(\"报表1\").Visible = 1

Sheets(\"报表1\").PrintOut Copies:=1, Collate:=True Sheets(\"报表1\").Visible = 0End Sub▲打开文件时执行指定宏(工作簿代码)

返回Private Sub Workbook_Open()

59/144

重排窗口 '要执行的宏名称End Sub

▲关闭文件时执行指定宏(工作簿代码)

返回Private Sub Workbook_BeforeClose(Cancel As Boolean) 重排窗口 '要执行的宏名称End Sub▲弹出提示A1单元内容

返回Sub 弹出提示A1单元内容()

MsgBox \"提示\" & Range(\"A1\").ValueEnd Sub

▲延时15秒执行重排窗口宏

返回Sub 延时15秒重排窗口()

Application.OnTime Now + TimeValue(\"00:00:15\"), \"重排窗口\"End Sub▲撤消工作表保护并取消密码

返回

Sub 撤消工作表保护并取消密码()

ActiveSheet.Unprotect Password:=123456End Sub▲重算指定表

返回

Sub 重算指定表()

Worksheets(\"传送参数\").CalculateWorksheets(\"目录\").CalculateEnd Sub▲将第5行移到窗口的最上面

返回

Worksheets(\"Sheet1\").ActivateActiveWindow.ScrollRow = 5▲对第一张工作表的指定区域进行排序

返回60/144

Sub 对第一张工作表的指定区域进行排序() With Worksheets(1)

.Range(\"a2:a100\").Sort Key1:=.Range(\"a1\") End WithEnd Sub

▲显示指定工作表的打印预览

返回Sub 显示指定工作表的打印预览()Worksheets(\"Sheet1\").PrintPreviewEnd Sub

▲用单元格A1的内容作为文件名另存当前工作簿

返回Sub b()

ActiveWorkbook.SaveCopyAs Range(\"A1\") + \".xls\"End Sub

▲[禁用/启用]保存和另存的代码

返回

Sub 禁用保存()

Application.CommandBars(\"File\").Controls(4).Enabled = FalseApplication.CommandBars(\"File\").Controls(5).Enabled = FalseEnd Sub

Sub 启用保存()

Application.CommandBars(\"File\").Controls(4).Enabled = TrueApplication.CommandBars(\"File\").Controls(5).Enabled = TrueEnd Sub

▲在A和B列返回当前选区的名称和公式

返回Sub 在A和B列返回当前选区的名称和公式()[a1].ListNamesEnd Sub▲朗读朗读A列,按ESC键中止

返回Sub 朗读A列()

61/144

Dim myStr$, i&, tRng As Range Dim mySpk As Speech

i = [A65536].End(xlUp).Row Set mySpk = Application.Speech

myStr = Replace(Replace(Range(\"A1:A\" & i).Address, \"$\ On Error Resume Next With mySpk

.Speak \"_\

For Each tRng In Range(\"A1:A\" & i)

If Err.Number <> 0 Then .Speak \"_\ If Not tRng Is Nothing Then .Speak tRng, , , False Next End WithEnd Sub

▲朗读固定语句，请按ESC键终止

返回

Sub 朗读固定语句()

On Error Resume Next

Application.Speech.Speak \"你好，节日快乐。\ If Err.Number <> 0 Then

Application.Speech.Speak \"\ End IfEnd Sub

▲在M和N列的14行以下选择单元时显示调用日历控件（工作表代码）返回

Private Sub Calendar1_Click() With Calendar1

ActiveCell = .Value .Visible = False End WithEnd Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Column = 13 And Target.Row > 3 Or Target.Column = 14 And Target.Row > 3 Then If IsDate(Target) Then

62/144

Calendar1.Value = Target Else

Calendar1.Today End If

Calendar1.Visible = -20

Calendar1.Top = ActiveCell.Top + ActiveCell.Height

Calendar1.Left = ActiveCell.Left + Cells(ActiveCell.Rows.Count, 1).Left Else

Calendar1.Visible = 0 End IfEnd Sub

'丢失复制功能

▲添加自定义序列

返回Sub 添加自定义序列()

Application.AddCustomList ListArray:=Array(\"优\End Sub▲弹出打印对话框

返回

Sub 弹出打印对话框()

Application.Dialogs(xlDialogPrint).ShowEnd Sub▲返回总页码

返回

Sub 返回总页码() Dim a

Sheet1.Activate

a = ExecuteExcel4Macro(\"Get.Document(50)\") Range(\"A1\") = aEnd Sub▲合并各工作表内容

返回Sub 合并各工作表内容()

sp = InputBox(\"各表内容之间，间隔几行？不输则默认为0\")

63/144

If sp = \"\" Then sp = 0End If

st = InputBox(\"各表从第几行开始合并？不输则默认为2\")If st = \"\" Then st = 2End If

Sheets(1).SelectSheets.Add

If st > 1 Then Sheets(2).Select

Rows(\"1:\" & CStr(st - 1)).Select Selection.Copy Sheets(1).Select Range(\"A1\").Select ActiveSheet.Paste y = st - 1 End If

For i = 2 To Sheets.Count

Sheets(i).Select For v = 1 To 256

zd = Cells(65535, v).End(xlUp).Row If zd > x Then x = zd End If Next v

If y + x - st + 1 + sp > 65536 Then

MsgBox \"内容太多，仅合并前\" & i - 2 & \"个表的内容，请把其它表复制到新工作薄里再用此程序合并！\"

/144

Else:

Rows(st & \":\" & x).Select Selection.Copy Sheets(1).Select

Range(\"A\" & CStr(y + 1)).Select ActiveSheet.Paste

Sheets(i).Select

Range(\"A1\").Select '取消单元格被全选状态。 Application.CutCopyMode = False '忘掉复制的内容。 End If

y = y + x - st + 1 + sp x = 0Next i

Sheets(1).Select

Range(\"A1\").Select '光标移至A1。MsgBox \"这就是合并后的表，请命名！\"End Sub

▲合并指定目录中所有文件中相同格式工作表的数据返回

Sub 合并数据()

'合并指定目录中所有文件中相同格式工作表的数据

'见http://club.excelhome.net/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 As Integer Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动 myPath = ThisWorkbook.Path & \"\\分表\\\" '把文件路径定义给变量

myFile = Dir(myPath & \"*.xls\") '依次找寻指定路径中的*.xls文件 Do While myFile <> \"\" '当指定路径中有文件时进行循环 If myFile <> ThisWorkbook.Name Then

65/144

Set AK = Workbooks.Open(myPath & myFile) '打开符合要求的文件 For i = 1 To AK.Sheets.Count

aRow = AK.Sheets(i).Range(\"a65536\").End(xlUp).Row

tRow = ThisWorkbook.Sheets(1).Range(\"a65536\").End(xlUp).Row + 1

'AK.Sheets(i).Select

AK.Sheets(i).Range(\"a3:k\" & aRow).Copy ThisWorkbook.Sheets(1).Range(\"a\" & tRow) '取得第3行以后的数据 Next

Workbooks(myFile).Close False '关闭源工作簿,并不作修改 End If

myFile = Dir '找寻下一个*.xls文件 Loop

Application.ScreenUpdating = True '冻结屏幕,此类语句一般成对使用 MsgBox \"汇总完成，请查看！\End Sub

▲隐藏指定工作表的指定列

返回

Sub 隐藏指定工作表的指定列()

Sheet1.Columns(\"B:B\").EntireColumn.Hidden = TrueEnd Sub▲把a列不重复值取到e列

返回

Sub 把a列不重复值取到e列()

[A:A].AdvancedFilter 2, , [e1], 1End Sub

▲当前选区的行列数

返回

Sub 当前选区的行列数()

Range(\"A1\") = Selection.Rows.Count '当前选区的行数Range(\"B1\") = Selection.Columns.Count '当前选区的列数End Sub

66/144

▲单元格录入1位字符就跳转(工作表代码)

返回

Private Sub TextBox1_Change()

If Len(Me.TextBox1.Text) <> 1 Then Exit SubMe.TextBox1.Activate

ActiveCell = Me.TextBox1.TextMe.TextBox1.Text = \"\"ActiveCell.Activate

Application.SendKeys \"~\"End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)With TextBox1

.Left = ActiveCell.Left.Top = ActiveCell.Top.Width = ActiveCell.Width.Height = ActiveCell.HeightEnd With

Me.TextBox1.ActivateEnd SubSub

▲当指定日期（每月10日）打开文件执行宏

返回

Sub auto_open()

If Day(Date) = 10 Then重排窗口End IfEnd Sub

▲提示并清空单元区域

返回

Sub 清空单元区域()

If MsgBox(\"是否真的要清空数据?清除后将无法恢复\ Range(\"A1:B10,A15:B25\").ClearContents End IfEnd Sub

67/144

▲返回光标所在行号

返回

Sub 返回光标所在行号()

Range(\"A1\") = Selection.RowEnd Sub

▲VBA返回公式结果

返回Sub VBA返回公式结果()

x = Application.WorksheetFunction.Sum(Range(\"a2:a100\"))Range(\"B1\") = xEnd Sub

▲按照当前行A列的图片名称插入图片到H列返回Sub 按照当前行A列的图片名称插入图片到H列()AAA = Selection.Row

Range(\"H\" & AAA).Select

Selection.RowHeight = 37 '指定行高

ActiveSheet.Pictures.Insert(ThisWorkbook.Path & \"\\\" & Range(\"A\" & Selection.Row) & \".JPG\").Select Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Height = 84.75 Selection.ShapeRange.Width = 150.75 Selection.ShapeRange.Rotation = 0#

Selection.ShapeRange.ScaleWidth 0.73, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight 0.73, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight 0.24, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft Range(\"H\" & AAA).SelectEnd Sub▲当前行下插入1行

返回

Sub 当前行下插入1行()

Selection.Offset(1, 0).InsertEnd Sub▲取消指定行或列的隐藏

返回68/144

Sub 取消隐藏行()

Rows(\"3:5\").Select

Selection.EntireRow.Hidden = FalseEnd Sub

Sub 取消隐藏列()

Columns(\"C:F\").Select

Selection.EntireColumn.Hidden = FalseEnd Sub

▲复制单元格所在行

返回Sub 复制单元格所在行()

Selection.EntireRow.CopyEnd Sub▲复制单元格所在列

返回

Sub 复制单元格所在列()

Selection.EntireColumn.CopyEnd Sub▲新建一个工作表

返回

Sub 新建一个工作表() Sheets.AddEnd Sub▲新建一个工作簿

返回

Sub 新建一个工作簿() Workbooks.AddEnd Sub

▲选择多表为工作组

返回

Sub 选择多表为工作组()

Dim Wks As Worksheet, shtCnt As Integer

Dim arr() As Variant, i As Integer, m As Integer, m1 As Integer, m2 As IntegershtCnt = ThisWorkbook.Sheets.Count '取得工作表总数

69/144

ReDim arr(1 To shtCnt) '预定义数组i = 0

m = 1 '循环的次数

m1 = 0 '找到起点循环的次数m2 = 0 '找到终点循环的次数

For Each Wks In ThisWorkbook.Sheets '在所有工作表中循环 If Wks.Name = \"A2\" Then '工作组中第一个工作表名称 i = i + 1

arr(i) = Wks.Name '将工作表名称存进数组 m1 = m End If

If Wks.Name Like \"A7\" Then '工作组中最后一个个工作表名称 i = i + 1

arr(i) = Wks.Name '将工作表名称存进数组 m2 = m Exit For End If

If i > 0 And m > m1 Then i = i + 1

arr(i) = Wks.Name '将工作表名称存进数组 End If m = m + 1Next

If m2 > m1 Then '如果存在符合条件的工作表名称 ReDim Preserve arr(1 To i) '重定义数组

ThisWorkbook.Sheets(arr).Select '选中符合条件的所有工作表End IfEnd Sub

▲在当前工作组各表中分别执行指定宏返回

'northwolves版主解答 http://club.excelhome.net/dispbbs.asp?boardid=2&id=251426&star=2#914934Sub 在当前工作组各表中分别执行指定宏()Dim SH As Worksheet

For Each SH In ActiveWindow.SelectedSheets70/144

'录制代码ActiveWorkbook.Nam

SH.Activate临时NextEnd Sub

'修改后的代码ActiveWorkbook

'临时宏中原录制代码ActiveWorkbook.Names.Add Name:=\"临时\ '临时宏经修改后的代码ActiveWorkbook.names.Add Name:=\"临时\ '冰山上的来客解答 http://club.excelhome.net/dispbbs.asp?boardid=2&id=251426 '其中指定宏代码一定要避免执行工作表的Select方法Dim SelShts As SheetsDim Sht As Worksheet

Sub 在当前工作组各表中分别执行指定宏()

Set SelShts = ActiveWindow.SelectedSheets For Each Sht In SelShts Call 临时 NextEnd Sub

▲复制当前工作簿的报表到临时工作簿

返回

Sub 复制当前工作簿的报表到临时工作簿()'作者：yuanzhuping版主Dim x As IntegerDim sht As WorksheetOn Error Resume Next

For x = 1 To Workbooks.Count

If Workbooks(x).Name = \"临时.xls\" Then For Each sht In Workbooks(x).Sheets If sht.Name = \"001\" Then

MsgBox \"已经有了001表\ Exit Sub End If

71/144

Next

Sheets(\"报表\").Copy Before:=Workbooks(\"临时.xls\").Sheets(1) ActiveSheet.Name = \"001\" Exit Sub End IfNext

Workbooks.Add

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & \"\\\" & \"临时\" ThisWorkbook.Activate

Sheets(\"报表\").Copy Before:=Workbooks(\"临时.xls\").Sheets(1) ActiveSheet.Name = \"001\"End Sub需求说明：

'复制当前工作簿的“报表”工作表到“临时”工作簿为“001”表。

'如果“临时”工作簿未打开，就创建新工作簿为“临时”并在其中加入“001”表；'如果“临时”工作簿已经打开，就直接加入“001”表。

'如果打开的“临时”工作簿中已经有“001”表，就报错退出。

'帖子地址：http://club.excelhome.net/dispbbs.asp?boardid=2&replyid=875804&id=245219&page=1&skin=0&Star=2▲删除指定文件

返回

Sub 删除指定文件()Kill \"E:\\信件\\1.xls\"End Sub

▲合并A1至C1的内容写到D15单元的批注中

返回

‘http://club.excelhome.net/dispbbs.asp?boardid=2&id=251887 northwolves版主Sub 将A1至C1的内容写到D15单元的批注中()

[iv1:iv12] = \"=rc1 & \"\" \"\"& rc2 &\"\" \"\"& rc3\"

[d15].AddComment Join(Application.Transpose([iv1:iv12]), vbCrLf)[iv1:iv12] = \"\"

[d15].Comment.Visible = True[d15].Comment.Shape.Height = 100End Sub

72/144

▲自动重算

返回

Sub 自动重算()

With Application

.Calculation = xlAutomatic End WithEnd Sub▲手动重算

返回Sub 手动重算()

With Application

.Calculation = xlManual End WithEnd Sub

73/144

74/144

开始就等于'完成',则只执行一次循环就退出

75/144

76/144

77/144

78/144

79/144

80/144

81/144

l.Top + ActiveCell.Height, 250#, 100).Select

82/144

83/144

84/144

85/144

86/144

87/144

el, \"工作表排序\")

88/144

/144

90/144

91/144

92/144

93/144

94/144

95/144

96/144

97/144

98/144

99/144

100/144

101/144

102/144

103/144

104/144

105/144

106/144

107/144

108/144

109/144

110/144

111/144

\"时\" & \"mm\" & \"分\" & \"ss\" & \"秒\") & \".xls\"

112/144

113/144

114/144

115/144

lTypeBlanks).EntireRow.Hidden)

116/144

117/144

118/144

119/144

120/144

121/144

122/144

123/144

124/144

125/144

126/144

127/144

128/144

ScreenTip:=\"点击转到:\" & Sheet1.Name & \"K\" & Rng.Row

r:=Cells(i + 1, 3), Address:=Cells(i + 1, 3)

129/144

Worksheets(\"数据库\").Cells(ier + 1, 3), Address:=Worksheets(\"数据库\").Cells(ier + 1, 3)

130/144

131/144

132/144

133/144

134/144

135/144

136/144

137/144

138/144

1楼eq800的代码

139/144

140/144

141/144

142/144

143/144

码ActiveWorkbook.Names.Add Name:=\"临时\

修改后的代码ActiveWorkbook.names.Add Name:=\"临时\

名称准备返回使用

+ \"!R1C1\" '插入名称准备返回使用

144/144