excel 259个常用宏

宏文件集

▲打开全部隐藏工作表返回Sub 打开全部隐藏工作表()

Dim i As Integer

For i = 1 To Sheets.Count

Sheets(i).Visible = True

Next i

End Sub

▲循环宏返回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 '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成 'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For '如果某列出现"完成"内容则退出循环

Next i

End Sub

▲录制宏时调用“停止录制”工具栏返回Sub 录制宏时调用停止录制工具栏()

https://www.sodocs.net/doc/e48463937.html,mandBars("Stop Recording").Visible = True

End Sub

▲高级筛选5列不重复数据至指定表返回Sub 高级筛选5列不重复数据至Sheet2()

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

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 _

:=xlPinYin

End 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 Select

End 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", "C4:C9")) Is Nothing Then Call 打开隐藏表

End Sub

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

If Range("$A$1") = "关闭" Then Exit Sub

Select Case Target.Address

Case "$A$5" '单元地址(Target.Address),或命名单元名字(https://www.sodocs.net/doc/e48463937.html,)

Call 宏1

Case "$B$5"

Call 宏2

Case "$C$5"

Call 宏3

End Select

End Sub

▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Range("$A$1") = "关闭" Then Exit Sub

If Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call 打开隐藏表

End Sub

▲在多个宏中依次循环执行一个（控件按钮代码）返回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

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

With CommandButton1

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

Call 保护工作表

.Caption = "取消工作表保护"

Exit Sub

End If

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

Call 取消工作表保护

.Caption = "保护工作表"

Exit Sub

End If

End With

End 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

Exit Sub

End If

End With

End Sub

▲根据A1单元文本隐藏/显示按钮（控件按钮代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Range("A1") > 2 Then

CommandButton1.Visible = 1

Else

CommandButton1.Visible = 0

End If

End Sub

Private Sub CommandButton1_Click()

重排窗口

End Sub

▲当前单元返回按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()

ActiveCell = CommandButton1.Caption

End Sub

▲当前单元内容返回到按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()

CommandButton1.Caption = ActiveCell

End Sub

▲奇偶页分别打印返回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 i = 2 To Ps Step 2

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

Next i

End Sub

▲自动打印多工作表第一页返回Sub 自动打印多工作表第一页()

Dim sh As Integer

Dim x

Dim y

Dim sy

Dim syz

x = InputBox("请输入起始工作表名字:")

sy = InputBox("请输入结束工作表名字:")

y = Sheets(x).Index

syz = Sheets(sy).Index

For sh = y To syz

Sheets(sh).Select

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

Next sh

End Sub

▲查找A列文本循环插入分页符返回Sub 循环插入分页符()

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

Dim i As Long

'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)

For i = 1 To times

Call 插入分页符

Next i

End Sub

Sub 插入分页符()

Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _

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

.Activate

ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell

End Sub

Sub 取消原分页()

Cells.Select

ActiveSheet.ResetAllPageBreaks

End 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

Next

End Sub

▲返回光标所在行数返回Sub 返回光标所在行数()

x = ActiveCell.Row

Range("A1") = x

End Sub

▲在A1返回当前选中单元格数量返回Sub 在A1返回当前选中单元格数量()

[A1] = Selection.Count

End Sub

▲返回当前工作簿中工作表数量返回Sub 返回当前工作簿中工作表数量()

t = Application.Sheets.Count

MsgBox t

End Sub

▲返回光标选择区域的行数和列数返回Sub 返回光标选择区域的行数和列数()

x = Selection.Rows.Count

y = Selection.Columns.Count

Range("A1") = x

Range("A2") = y

End Sub

▲工作表中包含数据的最大行数返回Sub 包含数据的最大行数()

n = Cells.Find("*", , , , 1, 2).Row

MsgBox n

End Sub

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

▲将所选区域文本插入新建文本框返回Sub 将所选区域文本插入新建文本框()

For Each rag In Selection

n = n & rag.Value & Chr(10)

Next

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

With Selection.Characters(Start:=1, Length:=3).Font

.Name = "黑体"

.FontStyle = "常规"

.Size = 12

End With

End Sub

▲批量插入地址批注返回Sub 批量插入地址批注()

On Error Resume Next

Dim r As Range

If Selection.Cells.Count > 0 Then

For Each r In Selection

https://www.sodocs.net/doc/e48463937.html,ment.Delete

r.AddComment

https://www.sodocs.net/doc/e48463937.html,ment.Visible = False

https://www.sodocs.net/doc/e48463937.html,ment.Text Text:="本单元格：" & r.Address & " of " & Selection.Address

Next

End If

End Sub

▲批量插入统一批注返回Sub 批量插入统一批注()

Dim r As Range, msg As String

msg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")

If Selection.Cells.Count > 0 Then

For Each r In Selection

r.AddComment

https://www.sodocs.net/doc/e48463937.html,ment.Visible = False

https://www.sodocs.net/doc/e48463937.html,ment.Text Text:=msg

Next

End If

End Sub

▲以A1单元内容批量插入批注返回Sub 以A1单元内容批量插入批注()

Dim r As Range

If Selection.Cells.Count > 0 Then

For Each r In Selection

r.AddComment

https://www.sodocs.net/doc/e48463937.html,ment.Visible = False

https://www.sodocs.net/doc/e48463937.html,ment.Text Text:=[a1].Text

Next

End If

End Sub

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

For Each mycell In Selection

mycell.FormulaR1C1 = "[" + https://www.sodocs.net/doc/e48463937.html, + "]" + https://www.sodocs.net/doc/e48463937.html, + "!" + mycell.Address

Next

End Sub

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

For Each mycell In Selection

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

Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

End Sub

▲返回当前单元地址返回Sub 返回当前单元地址()

d = ActiveCell.Address

[A1] = d

End 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 = https://www.sodocs.net/doc/e48463937.html,

End Sub

▲不连续区域添加文本返回Sub 批量添加文本()

Dim s As Range

For Each s In Selection

s = s & "文本内容"

Next

End Sub

▲不连续区域插入文本返回Sub 批量插入文本()

Dim s As Range

For Each s In Selection

s = "文本内容" & s

Next

End Sub

▲从指定位置向下同时录入多单元指定内容返回Sub 从指定位置向下同时录入多单元指定内容()

Dim arr

arr = Array("1", "2", "13", "25", "46", "12", "0", "20")

[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)

End Sub

▲按aa工作表A列的内容排列工作表标签顺序返回

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 = I + 1

Sheets("aa").Select

Loop

End Sub

▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()

Dim nm As String

nm = [a1]

Sheets.Add

https://www.sodocs.net/doc/e48463937.html, = nm

End 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) = https://www.sodocs.net/doc/e48463937.html,

n = n + 1

Next

Application.DisplayAlerts = False

For Each sht In Sheets

iFlag = False

For i = 1 To n - 1

If ShtName(i) = https://www.sodocs.net/doc/e48463937.html, Then

iFlag = True

Exit For

End If

Next

If Not iFlag Then sht.Delete

Next

Application.DisplayAlerts = True

End Sub

▲工作表标签排序返回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 Sub

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

If UCase(Sheets(j).Name) > UCase(Sheets(i).Name) Then

Sheets(j).Move Before:=Sheets(i)

End If

Next j

Next i

End If

End Sub

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

Sheets("Sheet1").Tab.ColorIndex = 46

End Sub

▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()

Dim s%, Rng As Range

On Error Resume Next

Sheets("目录").Activate

If Err = 0 Then

Sheets("目录").UsedRange.Delete

Else

Sheets.Add

https://www.sodocs.net/doc/e48463937.html, = "目录"

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", ScreenTip:=Sheets(i).Name

End If

Next

Sheets("目录").Range("b:iv").EntireColumn.ColumnWidth = 20

End Sub

▲建立工作表文本目录返回Sub 建立工作表文本目录()

Sheets.Add before:=Sheets(1)

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" '添加超链接

Next

End Sub

▲查另一文件的全部表名返回Sub 查另一文件的全部表名()

On Error Resume Next

Dim 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").Worksheets

Cells(i, 1) = https://www.sodocs.net/doc/e48463937.html, '将表名称返回到第1列

i = i + 1 '返回每个表名称向下移动1行

Next sh

Windows("2.xls").Close '关闭对象文件

▲当前单元录入计算机名返回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 Integer

For n = 1 To Sheets.Count

Sheets(n).Unprotect

Next n

End 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 '密码是123

MsgBox "密码错误,按确定退出!", 64, "提示"

Exit Sub

End If

Cells(1, 1) = 10

End Sub

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

If InputBox("请输入您的使用权限:", "系统提示") = 123 Then

重排窗口 '要执行的宏代码或宏名称

Else

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

End If

End Sub

▲拷贝A1公式和格式到A2返回Sub 拷贝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 插入数值条件格式()

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

End Sub

▲插入透明批注返回Sub 插入透明批注()

Selection.AddComment

https://www.sodocs.net/doc/e48463937.html,ment.Visible = False

Dim XS As Worksheet

For i = 1 To https://www.sodocs.net/doc/e48463937.html,ments.Count

https://www.sodocs.net/doc/e48463937.html,ments(i).Text "透明批注"

https://www.sodocs.net/doc/e48463937.html,ments(i).Shape.Fill.Visible = msoFalse

Next

End 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).Select

End Sub

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

Dim FirstCell As Range, FoundCell As Range

Dim AllCells As Range

With 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

https://www.sodocs.net/doc/e48463937.html, = https://www.sodocs.net/doc/e48463937.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.FormulaHidden

End With

Set FirstCell = https://www.sodocs.net/doc/e48463937.html,edRange.Find(what:="", searchformat:=True)

End If

Set AllCells = FirstCell

Set FoundCell = FirstCell

Do

Set FoundCell = https://www.sodocs.net/doc/e48463937.html,edRange.Find(After:=FoundCell, what:="", searchformat:=True)

If FoundCell Is Nothing Then Exit Do

Set AllCells = Union(FoundCell, AllCells)

If FoundCell.Address = FirstCell.Address Then Exit Do

Loop

AllCells.Select

End Sub

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

ABC = Selection

Dim aa As Range

For Each a In https://www.sodocs.net/doc/e48463937.html,edRange

If a Like ABC Then

If aa Is Nothing Then

Set aa = a.Cells

Else

Set aa = Union(aa, a.Cells)

End If

End If

Next

aa.Select

End Sub

▲按固定文本定位返回Sub 文本定位()

Dim aa As Range

For Each a In https://www.sodocs.net/doc/e48463937.html,edRange

If a Like "*合计*" Then

If aa Is Nothing Then

Set aa = a.Cells

Else

Set aa = Union(aa, a.Cells)

End If

End If

Next

aa.Select

End Sub

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

Do

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

Selection.EntireRow.Delete '删除行

' Selection.EntireColumn.Delete '删除列

Loop Until Cells.Find(what:="哈哈") Is Nothing

End Sub

▲定位数据及区域以上的空值返回Sub 定位数据及区域以上的空值()

Dim aa As Range

For Each a In https://www.sodocs.net/doc/e48463937.html,edRange

If a Like 〈0 Then

If aa Is Nothing Then

Set aa = a.Cells

Else

Set aa = Union(aa, a.Cells)

End If

aa.Select

End Sub

▲右侧单元自动加5(工作表代码)返回Private Sub Worksheet_Change(ByVal Target As Range)

Application.EnableEvents = False

Target.Offset(0, 1) = Target + 5

Application.EnableEvents = True

End 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 23

Cells(i, 1) = Cells(i, 1) - Cells(i, 2)

Next

End 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

Next

End Sub

▲将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

▲在指定颜色区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim myrg As Range

For Each myrg In Target

If myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> "√", "√", "")

Next

End 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

▲双击指定单元，循环录入文本（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)

If T.Address <> "$A$1" Then Exit Sub

Cancel = True

T = IIf(T = "好", "中", IIf(T = "中", "差", "好"))

End Sub

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

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)

Target.Offset(1, 0).Select

End If

End Sub

▲单元区域引用（工作表代码）返回Private Sub Worksheet_Activate()

Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").Value

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

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

End Sub

▲选择单元区域触发事件（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Address = "$A$1:$B$2" Then

MsgBox "你选择了$A$1:$B$2单元"

End If

End Sub

▲当修改指定单元内容时自动执行宏（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)

If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then

重排窗口

End If

End Sub

▲被指定单元内容限制执行宏返回Sub 被指定单元限制执行宏()

If Range("$A$1") = "关闭" Then Exit Sub

窗口

End Sub

▲双击单元隐藏该行（工作表代码）返回

End 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,15

End Sub

▲高亮显示行和列（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Cells.Interior.ColorIndex = xlNone

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

Columns(Target.Column).Interior.ColorIndex = 34

End 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, "", 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" Then

Call 宏名

End If

End 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 Then

Target.Offset(, -1) = Now

▲当指定区域修改时在其右侧的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

End If

End If

End Sub

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) = Format(Now(), "yyyy-mm-dd")

Target.Offset(, 2) = Format(Now(), "h:mm:ss")

End If

End If

End Sub

▲指定单元显示光标位置内容（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal T As Range)

Sheets(1).Range("A1") = Selection

End Sub

▲每编辑一个单元保存文件返回Private Sub Worksheet_Change(ByVal Target As Range)

ThisWorkbook.Save

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

▲删除A列非数字单元行返回Sub 删除A列非数字单元行()

i = [a65536].End(xlUp).Row

Range("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete

End Sub

▲有条件删除当前行返回Sub 有条件删除当前行()

If [A1] = 2 Or [B1] = "删除" Then

▲选择下一行返回Sub 选择下一行()

ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select

End Sub

▲选择第5行开始所有数据行返回Sub 选择第5行开始所有数据行A()

Dim i%

i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).EntireRow.Row

Rows("5:" & i).Select

End Sub

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

Rows("5:" & Cells.Find("*", , , , 1, 2).Row).Select

End Sub

▲选择光标或选区所在行返回Sub 选择光标或选区所在行()

Selection.EntireRow.Select

End Sub

▲选择光标或选区所在列返回Sub 选择光标或选区所在列()

Selection.EntireColumn.Select

End 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).Select

End 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

End Sub

▲单元反选返回Sub 单元反选()

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Dim raddress As String, taddress As String

raddress = Selection.Address

taddress = https://www.sodocs.net/doc/e48463937.html,edRange.Address

With Sheets.Add

.Range(taddress) = 0

End With

ActiveSheet.Range(raddress).Select

Application.ScreenUpdating = True

End Sub

▲调整选中对象中的文字返回Sub 调整选中对象中的文字()

'文字居中、自动调整大小

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.ReadingOrder = xlContext

.Orientation = xlHorizontal

.AutoSize = True

.AddIndent = False

End With

End 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

Next

End Sub

▲更新透视表数据项返回Sub DeleteMissingItems2002All()

'防止数据透视表中显示无用的数据项

'在 Excel 2002 或更高版本中

'如果无用的数据项已经存在,

'运行这个宏可以更新

Dim pt As PivotTable

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets

For Each pt In ws.PivotTables

pt.PivotCache.MissingItemsLimit = xlMissingItemsNone

Next pt

Next ws

End Sub

▲将全部工作表名称写到A列返回Sub 将全部表名称写到A列()

k = 1

For Each Sht In Sheets

Cells(k + 1, 1) = https://www.sodocs.net/doc/e48463937.html, '指定写入的行和列

k = k + 1

Next

End Sub

▲为当前选定的多单元插入指定名称返回Sub 为当前选定的多单元插入指定名称()

https://www.sodocs.net/doc/e48463937.html, = "临时"

https://www.sodocs.net/doc/e48463937.html,s.Add Name:="临时", RefersTo:=Selection '或者换用这行代码也可以

End Sub

▲删除全部名称返回Sub 删除全部名称()

On Error Resume Next

Dim l As Integer

l = https://www.sodocs.net/doc/e48463937.html,s.Count

For i = l To 1 Step -1

https://www.sodocs.net/doc/e48463937.html,s(i).Delete

▲以指定区域为表目录补充新表返回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 https://www.sodocs.net/doc/e48463937.html,, ""

Next

For Each item In arr

If item <> "" And Not dic.exists(Trim(item)) Then

With ThisWorkbook.Worksheets.Add

.Name = item

End With

End If

Next

Set dic = Nothing

End Sub

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

Dim i%

For i = 1 To Sheets.Count - 1

Sheets(i).Name = Cells(i + 1, 1).Text

Next

End Sub

▲按A列数据批量创建新表(控件按钮代码)返回Private Sub CommandButton1_Click()

On Error Resume Next

Dim i%, j%

For i = 1 To [a65536].End(xlUp).Row

For j = 2 To Sheets.Count

If Cells(i, 1) = Sheets(j).Name Then

Exit For

End If

Next

Sheets.Add(after:=Sheets(Sheets.Count)).Name = Cells(i, 1)

Next

End Sub

▲清除剪贴板返回Sub 清除剪贴板()

Application.CutCopyMode = False

https://www.sodocs.net/doc/e48463937.html,mandBars("Task Pane").Visible = False

End 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 Integer

For x = 1 To Workbooks.Count

If Workbooks(x).Name = "函数.xls" Then '文件名称

MsgBox "文件已打开"

Exit Sub

End If

Next

MsgBox "文件未打开"

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

ActiveWorkbook.SaveAs Filename:="E:\信件\" & https://www.sodocs.net/doc/e48463937.html,

End Sub

▲另存指定文件名返回Sub 另存指定文件名()

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

End Sub

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

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & https://www.sodocs.net/doc/e48463937.html, & ".xls"

End Sub

▲将本工作表单独另存文件到Excel当前默认目录返回Sub 将本工作表单独另存文件到Excel当前默认目录()

ActiveSheet.Copy

ActiveWorkbook.SaveAs Filename:=https://www.sodocs.net/doc/e48463937.html, & ".xls"

End Sub

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

ActiveWorkbook.SaveAs Filename:=https://www.sodocs.net/doc/e48463937.html, & ".xls", FileFormat:= _

xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _

, CreateBackup:=False

End Sub

▲另存所有工作表为工作簿返回Sub 另存所有工作表为工作簿()

Dim sht As Worksheet

Application.ScreenUpdating = False

ipath = ThisWorkbook.Path & "\"

For Each sht In Sheets

sht.Copy

ActiveWorkbook.SaveAs ipath & https://www.sodocs.net/doc/e48463937.html, & ".xls" '(工作表名称为文件名）

'ActiveWorkbook.SaveAs ipath & https://www.sodocs.net/doc/e48463937.html, & Trim(sht.[d15]) & ".xls" '（文件名称 & D15单元内容）

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

ActiveWorkbook.Close

Next

Application.ScreenUpdating = True

End Sub

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

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

End Sub

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

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

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

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

' FullName = Replace(ThisWorkbook.FullName, ".xls", https://www.sodocs.net/doc/e48463937.html, & ".txt") '以文件名&表名为TXT文件名 Open FullName For Output As #1 '以读写方式打开文件，每次写内容都会覆盖原先的内容

'参考帮助，fullname为文件全名

For Each rng In Range("a1").CurrentRegion

s = s & IIf(s = "", "", "|") & rng.Value

If rng.Column = Range("a1").CurrentRegion.Columns.Count Then

Print #1, s & "|" '把数据写到文本文件里

s = ""

End If

Next

Close #1 '关闭文件

Application.ScreenUpdating = True

MsgBox "数据已导入文本"

End Sub

▲引用指定位置单元内容为部分文件名另存文件返回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:=xlYes

End Sub

▲将指定范围的数据排列到D列返回Sub 将指定范围的数据排列到D列()

Dim arr1, arr2, i%, x

arr1 = 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) = x

Next x

Range("D1").Resize(i, 1) = arr2

End 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

End If

End Sub

▲加数据有效限制返回Sub 加数据有效限制()

With Selection.Validation

.Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _

xlBetween, Formula1:="bigsun010@https://www.sodocs.net/doc/e48463937.html,"

.IgnoreBlank = False

.InCellDropdown = False

.InputTitle = ""

.ErrorTitle = ""

.InputMessage = ""