超级好用的execl中的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.wendangku.net/doc/23887398.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
▲进入单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'以单元格进入代替按钮对象调用宏
If Range("$A$1") = "关闭" Then Exit Sub
Select Case Target.Address
Case "$A$5" '单元地址(Target.Address),或命名单元名字(https://www.wendangku.net/doc/23887398.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
Call 宏3
.Caption = "宏1"
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
Dim times As Long
times = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页")
'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列数据的最大行数()
n = Range("a65536").End(xlUp).Row
Range("B1") = n
End Sub
▲将所选区域文本插入新建文本框返回
Sub 将所选区域文本插入新建文本框()
For Each rag In Selection
n = 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 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.wendangku.net/doc/23887398.html,ment.Delete
r.AddComment
https://www.wendangku.net/doc/23887398.html,ment.Visible = False
https://www.wendangku.net/doc/23887398.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.wendangku.net/doc/23887398.html,ment.Visible = False
https://www.wendangku.net/doc/23887398.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.wendangku.net/doc/23887398.html,ment.Visible = False
https://www.wendangku.net/doc/23887398.html,ment.Text Text:=[a1].Text
Next
End If
End Sub
▲不连续区域插入当前文件名和表名及地址返回Sub 批量插入当前文件名和表名及地址()
For Each mycell In Selection
mycell.FormulaR1C1 = "[" + https://www.wendangku.net/doc/23887398.html, + "]" + https://www.wendangku.net/doc/23887398.html, + "!" + mycell.Address Next
End Sub
▲不连续区域录入当前单元地址返回Sub 区域录入当前单元地址()
For Each mycell In Selection
mycell.FormulaR1C1 = mycell.Address
Next
End Sub
▲连续区域录入当前单元地址返回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.wendangku.net/doc/23887398.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列的内容排列工作表标签顺序返回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 = I + 1
Sheets("aa").Select
Loop
End Sub
▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()
Dim nm As String
nm = [a1]
Sheets.Add
https://www.wendangku.net/doc/23887398.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.wendangku.net/doc/23887398.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.wendangku.net/doc/23887398.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
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
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.wendangku.net/doc/23887398.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.wendangku.net/doc/23887398.html, '将表名称返回到第1列
i = i + 1 '返回每个表名称向下移动1行
Next sh
Windows("2.xls").Close '关闭对象文件
Application.ScreenUpdating = True
End Sub
▲当前单元录入计算机名返回Sub 当前单元录入计算机名()
Selection = Environ("COMPUTERNAME")
'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容
End Sub
▲当前单元录入计算机用户名返回 Sub 当前单元录入计算机用户名()
Selection = Environ("Username")
'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容
End Sub
▲解除全部工作表保护返回Sub 解除全部工作表保护()
Dim n As 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 插入数值条件格式()
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
End Sub
▲插入透明批注返回Sub 插入透明批注()
Selection.AddComment
https://www.wendangku.net/doc/23887398.html,ment.Visible = False
Dim XS As Worksheet
For i = 1 To https://www.wendangku.net/doc/23887398.html,ments.Count
https://www.wendangku.net/doc/23887398.html,ments(i).Text "透明批注"
https://www.wendangku.net/doc/23887398.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.wendangku.net/doc/23887398.html, = https://www.wendangku.net/doc/23887398.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.wendangku.net/doc/23887398.html,edRange.Find(what:="", searchformat:=True)
If FirstCell Is Nothing Then
Exit Sub
End If
Set AllCells = FirstCell
Set FoundCell = FirstCell
Do
Set FoundCell = https://www.wendangku.net/doc/23887398.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
- vba常用宏
- Excel宏大量简单常用宏
- 259个常用宏_Excel Home
- Excel宏---259个常用宏知识讲解
- Execl宏程序总结
- Excel宏---259个常用宏
- (Excel)259个常用宏(VBA)教学提纲
- 259个常用EXCEL宏
- 3.35法师常用宏
- 259个常用excel宏,工作中用到的机会很多
- 145037_Excel常用宏(经典)
- 计算机二级access常用宏操作
- EXCEL一般常用宏.
- EXCEL中259个常用宏,灰常实用
- excel常用宏
- 副本Excel宏---259个常用宏
- VBA程序开发--259个常用宏
- excel常用宏集合
- excel常用宏集合
- excel259个常用宏