Excel259个常用宏
我的图书馆
Excel259个常用宏
Excel259个常用宏
作者:hessen | 时间: 23:41:05 | 浏览次数:98
打开全部隐藏工作表
Dim i As Integer
For i = 1 To Sheets.Count
&&& Sheets(i).Visible = True
Sub 循环()
AAA = Range("C2")
& Dim i As Long
& Dim times As Long
& times = AAA
&&& 'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于)
& For i = 1 To times
Call 过滤一行
&& If Range("完成标志") = "完成" Then Exit For& '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则只执行一次循环就退出
& 'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For&&&&&& '如果某列出现"完成"内容则退出循环
录制宏时调用“停止录制”工具栏
Sub 录制宏时调用停止录制工具栏()
Application.CommandBars("Stop Recording").Visible = True
高级筛选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
双击单元执行宏(工作表代码)
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
双击指定区域单元执行宏(工作表代码)
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 打开隐藏表
进入单元执行宏(工作表代码)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
&'以单元格进入代替按钮对象调用宏
&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 Select
进入指定区域单元执行宏(工作表代码)
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 打开隐藏表
在多个宏中依次循环执行一个（控件按钮代码）
Private Sub CommandButton1_Click()
Static RunMacro As Integer
Select Case RunMacro
& RunMacro = 1
& RunMacro = 2
&RunMacro = 0
End Select
在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）
Private Sub CommandButton1_Click()
With CommandButton1
&& If .Caption = "保护工作表" Then
&&&&& Call 保护工作表
&&&&&&&& .Caption = "取消工作表保护"
&&&&& Exit Sub
&& If .Caption = "取消工作表保护" Then
&&&&& Call 取消工作表保护
&&&&&&&&& .Caption = "保护工作表"
&&&&& Exit Sub
在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）
Option Explicit
Private Sub CommandButton1_Click()
With CommandButton1
&& If .Caption = "宏1" Then
&&&&& Call 宏1
&&&&&&&& .Caption = "宏2"
&&&&& Exit Sub
&& If .Caption = "宏2" Then
&&&&& Call 宏2
&&&&&&&& .Caption = "宏3"
&&&&& Exit Sub
&& If .Caption = "宏3" Then
&&&&& Call 宏3
&&&&&&&& .Caption = "宏1"
&&&&& Exit Sub
根据A1单元文本隐藏/显示按钮（控件按钮代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("A1") & 2 Then
CommandButton1.Visible = 1
CommandButton1.Visible = 0
Private Sub CommandButton1_Click()
当前单元返回按钮名称（控件按钮代码）
Private Sub CommandButton1_Click()
ActiveCell = CommandButton1.Caption
当前单元内容返回到按钮名称（控件按钮代码）
Private Sub CommandButton1_Click()
CommandButton1.Caption = ActiveCell
奇偶页分别打印
Sub 奇偶页分别打印()
& Dim i%, Ps%
& Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数
& MsgBox "现在打印奇数页,按确定开始."
& For i = 1 To Ps Step 2
&&& ActiveSheet.PrintOut from:=i, To:=i
& MsgBox "现在打印偶数页,按确定开始."
& For i = 2 To Ps Step 2
&&& ActiveSheet.PrintOut from:=i, To:=i
自动打印多工作表第一页
Sub 自动打印多工作表第一页()
Dim sh As Integer
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
查找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，不可大于)
& For i = 1 To times
Call 插入分页符
Sub 插入分页符()
&& Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
&&&&&&& xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
&&&&&&& .Activate
&&& ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
Sub 取消原分页()
&&& Cells.Select
&&& ActiveSheet.ResetAllPageBreaks
将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
返回光标所在行数
Sub 返回光标所在行数()
x = ActiveCell.Row
& Range("A1") = x
在A1返回当前选中单元格数量
Sub 在A1返回当前选中单元格数量()
[A1] = Selection.Count
返回当前工作簿中工作表数量
Sub 返回当前工作簿中工作表数量()
t = Application.Sheets.Count
返回光标选择区域的行数和列数
Sub 返回光标选择区域的行数和列数()
x = Selection.Rows.Count
y = Selection.Columns.Count
Range("A1") = x
Range("A2") = y
工作表中包含数据的最大行数
Sub 包含数据的最大行数()
n = Cells.Find("*", , , , 1, 2).Row
返回A列数据的最大行数
Sub 返回A列数据的最大行数()
n = Range("a65536").End(xlUp).Row
Range("B1") = n
将所选区域文本插入新建文本框
Sub 将所选区域文本插入新建文本框()
For Each rag In Selection
n = n & rag.Value & Chr(10)
&&& ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + ActiveCell.Height, 250#, 100).Select
&&& Selection.Characters.Text = "问题：" & n
&&& With Selection.Characters(Start:=1, Length:=3).Font
&&&&&&& .Name = "黑体"
&&&&&&& .FontStyle = "常规"
&&&&&&& .Size = 12
&&& End With
批量插入地址批注
Sub 批量插入地址批注()
On Error Resume Next
Dim r As Range
If Selection.Cells.Count & 0 Then
For Each r In Selection
r.Comment.Delete
r.AddComment
r.Comment.Visible = False
r.Comment.Text Text:="本单元格：" & r.Address & " of " & Selection.Address
批量插入统一批注
Sub 批量插入统一批注()
Dim r As Range, msg As String
msg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")
If Selection.Cells.Count & 0 Then
For Each r In Selection
r.AddComment
r.Comment.Visible = False
r.Comment.Text Text:=msg
以A1单元内容批量插入批注
Sub 以A1单元内容批量插入批注()
Dim r As Range
If Selection.Cells.Count & 0 Then
For Each r In Selection
r.AddComment
r.Comment.Visible = False
r.Comment.Text Text:=[a1].Text
不连续区域插入当前文件名和表名及地址
Sub 批量插入当前文件名和表名及地址()
&&& For Each mycell In Selection
&&&&&&& mycell.FormulaR1C1 = "[" + ActiveWorkbook.Name + "]" + ActiveSheet.Name + "!" + mycell.Address
不连续区域录入当前单元地址
Sub 区域录入当前单元地址()
&&& For Each mycell In Selection
&&&&&&& mycell.FormulaR1C1 = mycell.Address
连续区域录入当前单元地址
Sub 连续区域录入当前单元地址()
&&& Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"
&&& Selection.Copy
&&& Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
&&&&&&& :=False, Transpose:=False
返回当前单元地址
Sub 返回当前单元地址()
d = ActiveCell.Address
不连续区域录入当前日期
Sub 区域录入当前日期()
&& Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")
&& End Sub
不连续区域录入当前数字日期
Sub 区域录入当前数字日期()
&& Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")
不连续区域录入当前日期和时间
Sub 区域录入当前日期和时间()
&&& Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")
&& End Sub
不连续区域录入对勾
Sub 批量录入对勾()
Selection.FormulaR1C1 = "√"
不连续区域录入当前文件名
Sub 批量录入当前文件名()
Selection.FormulaR1C1 = ThisWorkbook.Name
不连续区域添加文本
Sub 批量添加文本()
Dim s As Range
For Each s In Selection
s = s & "文本内容"
不连续区域插入文本
Sub 批量插入文本()
Dim s As Range
For Each s In Selection
s = "文本内容" & s
从指定位置向下同时录入多单元指定内容
Sub 从指定位置向下同时录入多单元指定内容()
arr = Array("1", "2", "13", "25", "46", "12", "0", "20")
[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)
按aa工作表A列的内容排列工作表标签顺序
Sub 按aa工作表A列的内容排列工作表标签顺序()
&&& Dim I%, str1$
&&& 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
以A1单元文本作表名插入工作表
Sub 以A1单元文本作表名插入工作表()
&&& Dim nm As String
&&& nm = [a1]
&&& Sheets.Add
&&& ActiveSheet.Name = nm
删除全部未选定工作表
Sub 删除全部未选定工作表()
&&& Dim sht As Worksheet, n As Integer, iFlag As Boolean
&&& Dim ShtName() As String
&&& n = ActiveWindow.SelectedSheets.Count
&&& ReDim ShtName(1 To n)
&&& For Each sht In ActiveWindow.SelectedSheets
&&&&&&& ShtName(n) = sht.Name
&&&&&&& n = n + 1
&&& 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
&&&&&&&&&&& End If
&&&&&&& Next
&&&&&&& If Not iFlag Then sht.Delete
&&& Application.DisplayAlerts = True
工作表标签排序
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
定义指定工作表标签颜色
Sub 定义指定工作表标签颜色()
Sheets("Sheet1").Tab.ColorIndex = 46
在目录表建立本工作簿中各表链接目录
Sub 在目录表建立本工作簿中各表链接目录()
Dim s%, Rng As Range
&&& On Error Resume Next
&&& Sheets("目录").Activate
&&& If Err = 0 Then
&&&&&&& Sheets("目录").UsedRange.Delete
&&&&&&& Sheets.Add
&&&&&&& ActiveSheet.Name = "目录"
&&& End If
&,nb,&& 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
&&& Sheets("目录").Range("b:iv").EntireColumn.ColumnWidth = 20
建立工作表文本目录
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"&& '添加超链接
查另一文件的全部表名
Sub 查另一文件的全部表名()
On Error Resume Next
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) = sh.Name&&&& '将表名称返回到第1列
i = i + 1&&&&&&&&&&&& '返回每个表名称向下移动1行
Windows("2.xls").Close&&&& '关闭对象文件
Application.ScreenUpdating = True
当前单元录入计算机名
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
为指定工作表加指定密码保护表
Sub 为指定工作表加指定密码保护表()
Sheet10.Protect Password:="123"
在有密码的工作表执行代码
Sub 在有密码的工作表执行代码()
Sheets("1").Unprotect Password:=123 '假定表名为“1”，密码为“123”& 打开工作表
Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True&& '隐藏C列空值行
Sheets("1").Protect Password:=123&&& '重新用密码保护工作表
执行前需要验证密码的宏(控件按钮代码)
Private Sub CommandButton1_Click()
If InputBox("请输入密码：") && "123" Then& '密码是123
MsgBox "密码错误,按确定退出!", 64, "提示"
Cells(1, 1) = 10
Sub 执行前需要验证密码的宏()
If InputBox("请输入您的使用权限:", "系统提示") = 123 Then
重排窗口&& '要执行的宏代码或宏名称
MsgBox "对不起,您没有使用该宏的权限,按确定键后退出!"
拷贝A1公式和格式到A2
Sub 拷贝A1公式到A2()
Workbooks("临时表").Sheets("表1").Range("A1").Copy
Workbooks("临时表").Sheets("表2").Range("A2").PasteSpecial
复制单元数值
Sub 复制数值()
s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2")
Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = s
插入数值条件格式
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
插入透明批注
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 = msoFalse
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
定位选定单元格式相同的全部单元格
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
&&&&&&&&&&& .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:="", searchformat:=True)
&&&&&&& If FirstCell Is Nothing Then
&&&&&&& Exit Sub
&&&&&&& End If
&&& Set AllCells = FirstCell
&&& Set FoundCell = FirstCell
&&&&&&& Do
&&&&&&&&&&& Set FoundCell = ActiveSheet.UsedRange.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
按当前单元文本定位
Sub 按当前单元文本定位()
ABC = Selection
Dim aa As Range
For Each a In ActiveSheet.UsedRange
If a Like ABC Then
If aa Is Nothing Then
Set aa = a.Cells
Set aa = Union(aa, a.Cells)
按固定文本定位
Sub 文本定位()
Dim aa As Range
For Each a In ActiveSheet.UsedRange
If a Like "*合计*" Then
If aa Is Nothing Then
Set aa = a.Cells
Set aa = Union(aa, a.Cells)
删除包含固定文本单元的行或列
Sub 删除包含固定文本单元的行或列()
&Cells.Find(what:="哈哈").Activate
&Selection.EntireRow.Delete&&&&& '删除行
' Selection.EntireColumn.Delete& '删除列
Loop Until Cells.Find(what:="哈哈") Is Nothing
定位数据及区域以上的空值
Sub 定位数据及区域以上的空值()
Dim aa As Range
For Each a In ActiveSheet.UsedRange
If a Like 〈0 Then
If aa Is Nothing Then
Set aa = a.Cells
Set aa = Union(aa, a.Cells)
右侧单元自动加5(工作表代码)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Target.Offset(0, 1) = Target + 5
Application.EnableEvents = True
当前单元加2
Sub 当前单元加2()
&& Selection = Selection + 2
& 'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容
&, FONT style="FONT-SIZE: 12px"&&&& End Sub
A列等于A列减B列
Sub A列等于A列减B列()
For i = 1 To 23
Cells(i, 1) = Cells(i, 1) - Cells(i, 2)
用于光标选定多区域跳转指定单元(工作表代码)
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
将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
在指定颜色区域选择单元时添加/取消"√"（工作表代码）
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 && "√", "√", "")
在指定区域选择单元时添加/取消"√"（工作表代码）
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 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 = "中", "差", "好"))
双击指定单元，循环录入文本（工作表代码）
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
单元区域引用（工作表代码）
Private Sub Worksheet_Activate()
Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").Value
在指定区域选择单元时数值加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
混合文本的编号
Sub 混合文本的编号()
Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3, 100)) + 1)
指定区域单元双击数据累加（工作表代码）
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
选择单元区域触发事件（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$1:$B$2" Then
&& MsgBox "你选择了$A$1:$B$2单元"
当修改指定单元内容时自动执行宏（工作表代码）
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then
& 重排窗口
被指定单元内容限制执行宏
Sub 被指定单元限制执行宏()
If Range("$A$1") = "关闭" Then Exit Sub
双击单元隐藏该行（工作表代码）
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
& Rows(Target.Row).Hidden = True
高亮显示行（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.Interior.ColorIndex = 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
高亮显示行和列（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.Interior.ColorIndex = xlNone
Rows(Target.Row).Interior.ColorIndex = 34
Columns(Target.Column).Interior.ColorIndex = 34
为指定工作表设置滚动范围（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Sheet1.ScrollArea = "A1:M30"
在指定单元记录打印和预览次数（工作簿代码）
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Range("A1") = 1 + Range("A1")
自动数字金额转大写（工作表代码）
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))
将全部工作表的A1单元作为单击按钮（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Address = "$A$1" Then
&&& Call 宏名
闹钟----到指定时间执行宏（工作簿代码）
Private Sub Workbook_Open()
Application.OnTime ("11:45:00"), "提示1"&&& '宏名字
Application.OnTime ("12:00:00"), "提示2"&&& '宏名字
改变Excel界面标题的宏（工作簿代码）
Private Sub Workbook_Open()
Application.Caption = "春节快乐"
在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
&Worksheets("表2").Range("A1") = Target.Address(0, 0)
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
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")
指定单元显示光标位置内容（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal T As Range)
Sheets(1).Range("A1") = Selection
每编辑一个单元保存文件
Private Sub Worksheet_Change(ByVal Target As Range)
ThisWorkbook.Save
指定允许编辑区域
Sub 指定允许编辑区域()
ActiveSheet.ScrollArea = "B8:G15"
解除允许编辑区域限制
Sub 解除允许编辑区域限制()
ActiveSheet.ScrollArea = ""
删除指定行
Sub 删除指定行()
Workbooks("临时表").Sheets("表2").Range("5:5").Delete
删除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
删除A列非数字单元行
Sub 删除A列非数字单元行()
i = [a65536].End(xlUp).Row
Range("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
有条件删除当前行
Sub 有条件删除当前行()
If [A1] = 2 Or [B1] = "删除" Then
&Selection.Delete Shift:=xlUp
选择下一行
Sub 选择下一行()
&&& ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
选择第5行开始所有数据行
Sub 选择第5行开始所有数据行A()
&&& Dim i%
&&& i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).EntireRow.Row
&&& Rows("5:" & i).Select
Sub 选择第5行开始所有数据行B()
Rows("5:" & Cells.Find("*", , , , 1, 2).Row).Select
选择光标或选区所在行
Sub 选择光标或选区所在行()
&&& Selection.EntireRow.Select
选择光标或选区所在列
Sub 选择光标或选区所在列()
&&& Selection.EntireColumn.Select
光标定位到名称指定位置
Sub 定位()
Application.Goto Range(Evaluate("名称"))
选择名称定义的数据区
Sub 选择名称定义的数据区()
&&& [数据区].Select& '插入名称要使用INDIRECT函数
&&& 'Range("数据区").Select&&&&&&&& 或者
&&& 'Sheet1.Range("数据区").Select& 或者
选择到指定列的最后行
Sub 选择到指定列的最后行()
Range("C4:G" & [G65536].End(xlUp).Row).Select
将Sheet1的A列的非空值写到Sheet2的A列
Sub 将Sheet1的A列的非空值写到Sheet2的A列()
&&& Sheet1.Columns("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1]
将名称1的数据写到名称2
Sub Macro2()
Range("位置2") = Range("位置1").Value
Sub 单元反选()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim raddress As String, taddress As String
raddress = Selection.Address
taddress = ActiveSheet.UsedRange.Address
With Sheets.Add
.Range(taddress) = 0
.Range(raddress) = "=0"
raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address
ActiveSheet.Range(raddress).Select
Application.ScreenUpdating = True
调整选中对象中的文字
Sub 调整选中对象中的文字()
'文字居中、自动调整大小
&&& With Selection
&&&&&&& .HorizontalAlignment = xlCenter
&&&&&&& .VerticalAlignment = xlCenter
&&&&&&& .ReadingOrder = xlContext
&&&&&&& .Orientation = xlHorizontal
&&&&&&& .AutoSize = True
&&&&&&& .AddIndent = False
&&& End With
去除指定范围内的对象
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
更新透视表数据项
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
End Sub&&&&
将全部工作表名称写到A列
Sub 将全部表名称写到A列()
For Each Sht In Sheets
Cells(k + 1, 1) = Sht.Name&&&&&& '指定写入的行和列
为当前选定的多单元插入指定名称
Sub 为当前选定的多单元插入指定名称()
&Selection.Name = "临时"
ActiveWorkbook.Names.Add Name:="临时", RefersTo:=Selection&& '或者换用这行代码也可以
删除全部名称
Sub 删除全部名称()
On Error Resume Next
Dim l As Integer
l = ActiveWorkbook.Names.Count
For i = l To 1 Step -1
& ActiveWorkbook.Names(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 sh.Name, ""
&&& For Each item In arr
&&&&&&& If item && "" And Not dic.exists(Trim(item)) Then
&&&&&&&&&&& With ThisWorkbook.Worksheets.Add
&&&&&&&&&&&&&&&& .Name = item
&&&&&&&&&&& End With
&&&&&&& End If
Set dic = Nothing
按A列数据批量修改表名称
Sub 按A列数据批量修改表名称()
&&& Dim i%
&&& For i = 1 To Sheets.Count - 1
&&&&&&& Sheets(i).Name = Cells(i + 1, 1).Text
按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
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Cells(i, 1)
清除剪贴板
Sub 清除剪贴板()
&&& Application.CutCopyMode = False
&&& Application.CommandBars("Task Pane").Visible = False
批量清除软回车
Sub 批量清除软回车()
&&&&& '也可直接使用Alt+10或13替换
&&& Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:= _
&&&&&&& xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
判断指定文件是否已经打开
Sub 判断指定文件是否已经打开()
Dim x As Integer
&&& For x = 1 To Workbooks.Count
&&&&&&& If Workbooks(x).Name = "函数.xls" Then&&& '文件名称
&&&&&&&&&&& MsgBox "文件已打开"
&&&&&&&&&&& Exit Sub
&&&&&&& End If
&&& MsgBox "文件未打开"
当前文件另存到指定目录
Sub 当前激活文件另存到指定目录()
ActiveWorkbook.SaveAs Filename:="E:\信件\" & ActiveWorkbook.Name
另存指定文件名
Sub 另存指定文件名()
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\别名.xls"
以本工作表名称另存文件到当前目录
Sub 以本工作表名称另存文件到当前目录()
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls"
将本工作表单独另存文件到Excel当前默认目录
Sub 将本工作表单独另存文件到Excel当前默认目录()
ActiveSheet.Copy
&&& ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls"
以活动工作表名称另存文件到Excel当前默认目录
Sub 以活动工作表名称另存文件到Excel当前默认目录()
&&& ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls", FileFormat:= _
&&&&&&& xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
&&&&&&& , CreateBackup:=False
另存所有工作表为工作簿
Sub 另存所有工作表为工作簿()
Dim sht As Worksheet
Application.ScreenUpdating = False
ipath = 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.Close
Application.ScreenUpdating = True
以指定单元内容为新文件名另存文件
Sub 以指定单元内容为新文件名另存文件()
ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.[A1]
以当前日期为新文件名另存文件
Sub 以当前日期为新文件名另存文件()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls"
Sub 以当前日期为名称另存文件()
ActiveWorkbook.SaveAs Filename:=Date & ".xls"
以当前日期和时间为新文件名另存文件
Sub 以当前日期和时间为新文件名另存文件()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls"
另存本表为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")& '以当前文件名为TXT文件名
&'&& FullName = Replace(ThisWorkbook.FullName, ".xls", ActiveSheet.Name & ".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
&&& Close #1&& &'关闭文件
&&& Application.ScreenUpdating = True
&&& MsgBox "数据已导入文本"
引用指定位置单元内容为部分文件名另存文件
Sub 引用指定位置单元内容为部分文件名另存文件()
ActiveWorkbook.SaveAs Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls"
将A列数据排序到D列
Sub 将A列数据排序到D列() ,
[d:d] = [a:a].Value
[d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
将指定范围的数据排列到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
Range("D1").Resize(i, 1) = arr2
Sub 光标移动()
ActiveCell.Offset(1, 2).Select&& '向下移动1行，向右移动2列
光标所在行上移一行
Sub 光标所在行上移一行()
&&& Dim i%
&&& i = Split(ActiveCell.Address, "$")(2)
&&& If i & 1 Then
&&&&&&& Rows(i).Cut
&&&&&&& Rows(i - 1).Insert Shift:=xlDown
&&& End If
加数据有效限制
Sub 加数据有效限制()
&&& With Selection.Validation
&&&&&&& .Delete
&&&&&&& .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
&&&&&&& xlBetween, Formula1:=""
&&&&&&& .IgnoreBlank = False
&&&&&&& .InCellDropdown = False
&&&&&&& .InputTitle = ""
&&&&&&& .ErrorTitle = ""
&&&&&&& .InputMessage = ""
&&&&&&& .ErrorMessage = "要奋斗就会有牺牲，死人的事是经常发生的。"
&&&&&&& .IMEMode = xlIMEModeNoControl
&&&&&&& .ShowInput = True
&&&&&&& .ShowError = True
&&& End With
取消数据有效限制
Sub 取消数据有效限制()
&&& With Selection.Validation
&&&&&&& .Delete
&&&&&&& .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
&&&&&&& :=xlBetween
&&&&&&& .IgnoreBlank = False
&&&&&&& .InCellDropdown = False
&&&&&&& .InputTitle = ""
&&&&&&& .ErrorTitle = ""
&&&&&&& .InputMessage = ""
&&&&&&& .ErrorMessage = ""
&&&&&&& .IMEMode = xlIMEModeNoControl
&&&&&&& .ShowInput = True
&&&&&&& .ShowError = True
&&& End With
Sub 重排窗口()
&&& Application.CommandBars("Web").Visible = False
&&& Application.CommandBars("我的工具").Visible = False
&&& Windows.Arrange ArrangeStyle:=xlCascade
按当前单元文本选择打开指定文件单元
Sub 选择打开文件单元()
&&& a = ActiveCell.Value
&&& Range(a).Worksheet.Activate
&&& Range(a).Select
回车光标向右
Sub 录入光标向右()
&&& Application.MoveAfterReturnDirection = xlToRight
回车光标向下
Sub 录入光标向下()
&&& Application.MoveAfterReturnDirection = xlDown
保护工作表时取消选定锁定单元
Sub 取消选定锁定单元()
&&& ActiveSheet.EnableSelection = xlUnlockedCells&&& '用于2000版
保存并退出Excel
Sub 保存并退出Excel()
Application.SendKeys ("{ENTER}{ENTER}%fx")
ActiveWorkbook.Save
隐藏/显示指定列空值行
Sub 隐藏显示E列空值行()
Range("E1:E1000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = Not (Range("E1:E1000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden)
深度隐藏指定工作表
Sub 深度隐藏指定工作表()
Sheets("用户名密码").Visible = xlVeryHidden
隐藏指定工作表
Sub 隐藏指定工作表()
Sheets("用户名密码").Visible = false
隐藏当前工作表
Sub 隐藏当前工作表()
&&& ActiveWindow.SelectedSheets.Visible = false
返回当前工作表名称
Sub 返回当前工作表名称()
wsName = ActiveSheet.Name
MsgBox "当前工作表为：" & wsName
获取上一次所进入工作簿的工作表名称
Sub 获取上一次所进入工作簿的工作表名称()
MsgBox Workbooks(2).ActiveSheet.Name
按光标选定颜色隐藏本列其他颜色行
Sub 按颜色筛选() '思路就是:其它背景色之行全部隐藏
Dim UseRow, AC, i '首先选择一个有颜色之单元格，然后动行宏，其它颜色所在行隐藏
UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row 'SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格
If ActiveCell.Row & UseRow Then
&MsgBox "请在要筛选的区域选择一个有颜色之单元格！", vbExclamation, "错误"
&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至已用行之单元格的有列之颜色不等于当前单元格颜色则隐藏整行
打开工作簿自动隐藏录入表以外的其他表
Private Sub Workbook_Open()
For i = 1 To Sheets.Count
If Sheets(i).Name && "录入" Then
Sheets(i).Visible = False
除最左边工作表外深度隐藏所有表
Sub 除最左边工作表外深度隐藏所有表()
For i = 2 To ThisWorkbook.Sheets.Count
&&& Sheets(i).Visible = xlSheetVeryHidden
关闭文件时自动隐藏指定工作表(ThisWorkbook)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
&ActiveWorkbook.Unprotect
&&& Sheets("Sheet2").Visible = False
&&& Sheets("Sheet3").Visible = False
ActiveWorkbook.Protect Structure:=True, Windows:=False
打开文件时提示指定工作表是保护状态(ThisWorkbook)
Private Sub Workbook_Open()
If Worksheets("Sheet1").ProtectContents = True Then
&&& MsgBox " Sheet1 保护了."
Sub 插入10行()
&&& Rows(ActiveCell.Row & ":" & ActiveCell.Row + 9).Select
&&& Selection.Insert Shift:=xlDown
全选固定范围内小于0的单元
Sub 全选固定范围内小于0的单元()
Dim rng As Range
For Each rng In Range("d6: i18")
If rng & 0 Then
yvhf = yvhf & rng.Address & ","
Range(Left(yvhf, Len(yvhf) - 1)).Select
全选选定范围内小于0的单元
Sub 全选选定范围内小于0的单元()
Dim rng As Range
For Each rng In Selection
If rng & 0 Then
yvhf = yvhf & rng.Address & ","
Range(Left(yvhf, Len(yvhf) - 1)).Select
固定区域单元分类变色
Sub 单元分类变色()
Dim rng As Range
For Each rng In Range("d6: i18")
If rng & 0 Then
rng.Interior.ColorIndex = 4&& '小于0的单元变绿底色
For Each rng In Range("d6: i18")
If rng & 0 Then
rng.Interior.ColorIndex = 3&&& '文本、假空和大于0的单元变红底色
For Each rng In Range("d6: i18")
If rng = 0 Then
rng.Interior.ColorIndex = 2&& '空值和等于0的单元变白底色
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
& Application.ScreenUpdating = True
单元格录入数据时运行宏的代码
Private Sub Worksheet_Change(ByVal Target As Range)
焦点到A列时运行宏的代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
&&& If Target.Column = 1 Then
&&& End If
根据B列最后数据快速合并A列单元格的控件代码
Private Sub CommandButton1_Click()
For i = 1 To [b65536].End(xlUp).Row
&For j = i + 1 To [b65536].End(xlUp).Row
&If Range("a" & j) = "" Then
&& Range("a" & i & ":a" & j).Merge
&& Exit For
在F1单元显示光标位置批注内容的代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
a = S, election.Address
Cells(1, 6) = b
显示光标所在单元的批注的代码
Dim r As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
r.Comment.Visible = False
Set r = Target
r.Comment.Visible = True
使单元内容保持不变的工作表代码
Private Sub Worksheet_Change(ByVal Target As Range)
[B2] = "不可更改的数据"
有条件执行宏
Sub 高级筛选()
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:=False
有条件执行不同的宏
Sub 有条件执行不同的宏()
&If [b1].Value = "A" Then
& Application.Run "宏1"
ElseIf [b1].Value = "B" Then
& Application.Run "宏2"
提示确定或取消执行宏
Sub 提示确定或取消执行宏()
If vbOK = MsgBox("确定要复制吗?", vbOKCancel) Then
Range("A4:A14").Copy Range("b4:b14")
Msgbox "复制结束"
提示开始和结束
&Sub 提示结束()
Msgbox "运行开始"
Msgbox "运行结束"
拷贝指定表不相邻多列数据到新位置
Sub 拷贝指定表不相邻多列数据到新位置()
Sheets("sheet1").Range("A:A,J:J").Copy Range("d1")
选择2至4行
Sub 选择2至4行()
&&& Dim a As Integer
&&& Dim b As Integer
&&& Rows(a & ":" & b).Select
在当前选区有条件替换数值为文本
Sub 在当前选区有条件替换数值为文本()
For Each r In Selection
&&& If r.Value & 18 And r.Value & 29.5 Then r.Value = "Y"
自动筛选全部显示指定列
Sub 自动筛选全部显示指定列()
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=3
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6
自动筛选第2列值为A的行
Sub 自动筛选第2列值为A的行()
[a1].AutoFilter 2, "a"
取消自动筛选()
Sub 取消自动筛选()
&ActiveSheet.AutoFilterMode = False
全部显示指定表的自动筛选
Sub 全部显示指定表的自动筛选()
If Sheet1.FilterMode = True Then
&& Sheet1.ShowAllData
强行合并单元
Sub 强行合并单元()
& Application.DisplayAlerts = False '不出现对话框，按对话框默认选择
& Range("a3:a4").Merge
& Application.ScreenUpdating = True
设置单元区域格式
Sub 设置单元区域格式()
[a:a].NumberFormat = "yyyy.mm.dd"
& Sheet2.[B:B].NumberFormatLocal = "yyyy-m-d"
& Sheet2.[C:C].NumberFormatLocal = "G/通用格式"
在所有工作表的A1单元返回顺序号
Sub 在所有工作表的A1单元返回顺序号()
For i = 1 To Sheets.Count
Sheets(i).Cells(1, 1) = "'" & Application.WorksheetFunction.Text(0 + i, "000")
根据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 = "部门"
根据A1内容选择执行宏
Sub 根据A1内容选择执行宏()
&&& Select Case Sheet1.[A1]
&&& Case "A"
&&&&&&& 宏1
&&& Case "B"
&&&&&&& 宏2
&&& Case "C"
&&&&&&& 宏3
&&& Case Else
&&& End Select
删除A列空行
Sub 删除A列空行()
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
在A列产生不重复随机数
Sub 在A列产生不重复随机数()
&Randomize Timer
&Dim c(100) As Byte
&For i = 1 To 100 '产生100个随机数
& c(i) = i
&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) = aa
将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] = ""
取消选定区域的公式只保留值(假空转真空)
Sub 取消选定区域的公式只保留值()
&'&& Sheets("数据归并集中").Select&& '指定工作表
&'&& Columns("Q:R").Select&&&&&&&&&& '指定范围
Selection.Value = Selection.Value
处理导入的显示为科学计数法样式的***号
Sub 处理导入的显示为科学计数法样式的***号()
Selection.Value = Selection.Formula
返回指定单元的行高和列宽
Sub 返回指定单元的行高和列宽()
[c2] = Range("A1").ColumnWidth& '列宽
[b2] = Range("A1").RowHeight&&& '行高
Sub 返回指定单元的行高和列宽()
&&& Dim r%, c%
&&& r = [a1].RowHeight
&&& c = [a1].ColumnWidth
&&& [b2] = r& '行高
&&& [c2] = c& '列宽
指定行高和列宽
Sub 指定行高和列宽()
& Range("A1:F1").ColumnWidth = 10& '指定列宽
& Range("A2:A10").RowHeight = 40&& '指定行高
Sub 指定行高和列宽()
& Columns("A:F").ColumnWidth = 10& '指定列宽
& Rows("2:10").RowHeight = 40&&&&& '指定行高
指定单元的行高和列宽与A1单元相同
Sub 指定单元的行高和列宽与A1单元相同()
& Range("A1:F1").ColumnWidth = Range("A1").ColumnWidth& '指定列宽
& Range("A2:A10").RowHeight = Range("A1").RowHeight&& '指定行高
Sub 填公式()
Range("C2:C12").Value = "=SUM(A2:B2)"
建立当前工作表的副本为001表
Sub 建立当前工作表的副本为001表()
&&& ActiveSheet.Copy Before:=Sheets(1)
&&& ActiveSheet.Name = "001"
在第一个表前插入多工作表
Sub 在第一个表前插入多工作表()
Sheets(1).Select
For I = 1 To 50
Sheets.Add.Name = "新表" & I
清除A列再插入序号
Sub 清除A列再插入序号()
'Columns(1).ClearContents '清除A列内容
For i = 1 To 20
Range("a" & i) = i
反方向文本(自定义函数)
Function zhyz(zhyz1 As Range)
zhyz = StrReverse(zhyz1)
End Function
将代码复制到模块后单元公式：=zhyz(单元格)
指定选择单元区域弹出消息
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$1:$C$3" Then
&& MsgBox "你选择对了"
将B列数据添加超链接到K列
Sub 将B列数据添加超链接到K列()
&&& For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)
&&&&&&& ActiveSheet.Hyperlinks.Add Anchor:=Rng, Address:="", SubAddress:=Sheet1.Range("K" & Rng.Row).Address, ScreenTip:="点击转到:" & Sheet1.Name & "K" & Rng.Row
删除B列数据的超链接
Sub 删除超链接()
&&& For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)
&&&&&&& Sheet1.Range(Rng.Address).Hyperlinks.Delete
分离临时表A列数据的文本和超链接并整理到数据库表
Sub 分离A列中的超链接到指定表的B和C列()
i = Worksheets("数据库").Range("b60000").End(xlUp).Row
For Each h In, W, orksheets("临时").Hyperlinks
Worksheets("数据库").Cells(i + 1, 2) = h.Text, ToDisplay
Worksheets("数据库").Cells(i + 1, 3) = h.Address
Range(Worksheets("数据库").Cells(i + 1, 3), Worksheets("数据库").Cells(i + 1, 3)).Hyperlinks.Add Anchor:=Cells(i + 1, 3), Address:=Cells(i + 1, 3)
分离临时表A列数据的文本和超链接并会同其他数据整理到数据库表
Sub 分离A列数据的文本和超链接并会同其他数据整理到指定表()
&ier = Worksheets("数据库").Range("b60000").End(xlUp).Row
For ee = 5 To Range("a60000").End(xlUp).Row
For Each hh In Worksheets("临时").Hyperlinks
If hh.TextToDisplay = Cells(ee, 1) And Cells(ee, 1) && "" Then
www = www & "," & ee
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
& sdf = sdf + 1
For Each hhh In Worksheets("临时").Range("A6:A6000").Hyperlinks
Worksheets("数据库").Cells(ier + 1, 2) = hhh.TextToDisplay
Worksheets("数据库").Cells(ier + 1, 3) = hhh.Address
Range(Worksheets("数据库").Cells(ier + 1, 3), Worksheets("数据库").Cells(ier + 1, 3)).Hyperlinks.Add Anchor:=Worksheets("数据库").Cells(ier + 1, 3), Address:=Worksheets("数据库").Cells(ier + 1, 3)
ier = ier + 1
返回A列最后一个非空单元行号
Sub 返回A列最后非空单元行号()
MsgBox Cells.Range("A65536").End(xlUp).Row
返回表中第一个非空单元地址(行搜索)
Sub 返回表中第一个非空单元地址()
MsgBox Cells.Find("*").Address
返回表中各非空单元区域地址(行搜索)
Sub 返回表中各非空单元区域地址()
MsgBox Cells.SpecialCells(2).Address
返回第一个数值行号
Sub 返回第一个数值行号()
MsgBox [b:b].SpecialCells(2, 1).Row
返回第1行最右边非空单元的列号
Sub 返回第1行最右边非空单元的列号()
X = [IV1].End(xlToLeft).Column
返回连续数值单元的数量
Sub 返回连续数值单元的数量()
MsgBox [b:b].SpecialCells(2, 1).Rows.Count
统计指定范围和内容的单元数量
Sub 统计指定范围和内容的单元数量()
x = Application.WorksheetFunction.CountIf(Range("A3:B100"), "总计")
Range("B1") = x
统计不同颜色的数字的和（自定义函数）
Public Function COLOR(ByVal X As Range, Y)
For Each I In X
&&& If I.Font.ColorIndex = Y Then
&&&&&&&& COLOR = COLOR + I
&&& End If
End Function
'统计红色,输入：=COLOR(B2:B8,3)
'统计蓝色,输入：=COLOR(B2:B8,5)
返回非空单元数量
Sub 返回非空单元数量()
x = Application.CountA(Range("A1:Z65536"))
返回A列非空单元数量
Sub 返回A列非空单元数量()
y = Application.CountA(Columns(1))
返回圆周率π
Sub Macro1()
Range("A1") = Application.Pi()
定义指定单元内容为页眉/页脚
Sub 定义指定单元内容为页眉/页脚()
BBB = Sheets("表1").Range("A2")
&&& With ActiveSheet.PageSetup
&&&&&&& .CenterHeader = BBB&& '定义页眉
&'&&&&&& .CenterFooter = BBB&& '定义页脚
&&& End With
提示并全部清除当前选择区域
Sub 提示并全部清除当前选择区域()
& If MsgBox("你确定要清除选择的区域吗?", vbYesNo, " 提示:") = vbYes Then Selection.Clear
全部清除当前选择区域
Sub 全部清除当前选择区域()
Selection.Clear
&' Range("A1:B10").Clear&& &'全部清除指定区域
清除指定区域数值
Sub 清除单元数值()
Sheet1.[A1:A10].ClearContents
Sub 清除指定区域数值()
&&& Range("A1:C8") = ClearContents
Sub 清除指定区域数值()
&&& Sheet1.[A1:A10]=""
对指定工作表执行取消隐藏》打印》隐藏工作表
Sub 打印隐藏工作表()
& Sheets("报表1").Visible = 1
& Sheets("报表1").PrintOut Copies:=1, Collate:=True
& Sheets("报表1").Visible = 0
打开文件时执行指定宏(工作簿代码)
Private Sub Workbook_Open()&
&重排窗口&&& '要执行的宏名称
关闭文件时执行指定宏(工作簿代码)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
&重排窗口&&& '要执行的宏名称
弹出提示A1单元内容
Sub 弹出提示A1单元内容()
MsgBox "提示" & Range("A1").Value
延时15秒执行重排窗口宏
Sub 延时15秒重排窗口()
Application.OnTime Now + TimeValue("00:00:15"), "重排窗口"
撤消工作表保护并取消密码
Sub 撤消工作表保护并取消密码()
&ActiveSheet.Unprotect Password:=123456
重算指定表
Sub 重算指定表()
Worksheets("传送参数").Calculate
Worksheets("目录").Calculate
将第5行移到窗口的最上面
Worksheets("Sheet1").Activate
ActiveWindow.ScrollRow = 5
对第一张工作表的指定区域进行排序
Sub 对第一张工作表的指定区域进行排序()
&&& With Worksheets(1)
&&& .Range("a2:a100").Sort Key1:=.Range("a1")
&&& End With
显示指定工作表的打印预览
Sub 显示指定工作表的打印预览()
Worksheets("Sheet1").PrintPreview
用单元格A1的内容作为文件名另存当前工作簿
ActiveWorkbook.SaveCopyAs Range("A1") + ".xls"
[禁用/启用]保存和另存的代码
Sub 禁用保存()
Application.CommandBars("File").Controls(4).Enabled = False
Application.CommandBars("File").Controls(5).Enabled = False
Sub 启用保存()
Application.CommandBars("File").Controls(4).Enabled = True
Application.CommandBars("File").Controls(5).Enabled = True
在A和B列返回当前选区的名称和公式
Sub 在A和B列返回当前选区的名称和公式()
[a1].ListNames
朗读朗读A列,按ESC键中止
Sub 朗读A列()
&&& 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 "_", , , False
&&&&&&& For Each tRng In Range("A1:A" & i)
&&&&&&&&&&& If Err.Number && 0 Then .Speak "_", , , True: Exit Sub
&&&&&&&&&&& If Not tRng Is Nothing Then .Speak tRng, , , False
&&&&&&& Next
&&& End With
朗读固定语句，请按ESC键终止
Sub 朗读固定语句()
&&& On Error Resume Next
&&&&&&& Application.Speech.Speak "你好，节日快乐。", , , False
&&& If Err.Number && 0 Then
&&&&&&& Application.Speech.Speak "", , , True
&&& End If
在M和N列的14行以下选择单元时显示调用日历控件（工作表代码）
Private Sub Calendar1_Click()
&&& With Calendar1
&&&&&&& ActiveCell = .Value
&&&&&&& .Visible = False
&&& End With
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
&&&&&&&&&& 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
&&&&&&& Calendar1.Visible = 0
&&& End If
& '丢失复制功能
添加自定义序列
Sub 添加自定义序列()
&&& Application.AddCustomList ListArray:=Array("优","良", "中", "差"，"劣")
弹出打印对话框
Sub 弹出打印对话框()
Application.Dialogs(xlDialogPrint).Show
返回总页码
Sub 返回总页码()
&&& Sheet1.Activate
&&& a = ExecuteExcel4Macro("Get.Document(50)")
&&& Range("A1") = a
合并各工作表内容
Sub 合并各工作表内容()
sp = InputBox("各表内容之间，间隔几行？不输则默认为0")&, /TD, &
If sp = "" Then
st = InputBox("各表从第几行开始合并？不输则默认为2")
If st = "" Then
Sheets(1).Select
Sheets.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
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 & "个表的内容，请把其它表复制到新工作薄里再用此程序合并！"
& 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&&&&&&&&&& '忘掉复制的内容。
& y = y + x - st + 1 + sp
Sheets(1).Select
Range("A1").Select&&&&&&&&&&&&&&&&&&&&&&&&& '光标移至A1。
MsgBox "这就是合并后的表，请命名！"
合并指定目录中所有文件中相同格式工作表的数据
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
&&&&&&&& 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文件
&& Application.ScreenUpdating = True&&&&&&&&&&&&&&&& '冻结屏幕,此类语句一般成对使用
&& MsgBox "汇总完成，请查看！", 64, "提示"
隐藏指定工作表的指定列
Sub 隐藏指定工作表的指定列()
Sheet1.Columns("B:B").EntireColumn.Hidden = True
把a列不重复值取到e列
Sub 把a列不重复值取到e列()
[A:A].AdvancedFilter 2, , [e1], 1
当前选区的行列数
Sub 当前选区的行列数()
Range("A1") = Selection.Rows.Count&&&&& '当前选区的行数
Range("B1") = Selection.Columns.Count&& '当前选区的列数
单元格录入1位字符就跳转(工作表代码)
Private Sub TextBox1_Change()
If Len(Me.TextBox1.Text) && 1 Then Exit Sub
Me.TextBox1.Activate
ActiveCell = Me.TextBox1.Text
Me.TextBox1.Text = ""
ActiveCell.Activate
Application.SendKeys "~"
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With TextBox1
.Left = ActiveCell.Left
.Top = ActiveCell.Top
.Width = ActiveCell.Width
.Height = ActiveCell.Height
Me.TextBox1.Activate
End SubSub
当指定日期（每月10日）打开文件执行宏
Sub auto_open()
If Day(Date) = 10 Then
提示并清空单元区域
Sub 清空单元区域()
&If MsgBox("是否真的要清空数据?清除后将无法恢复", 1 + vbokNo) = vbOK Then
&&& Range("A1:B10,A15:B25").ClearContents
返回光标所在行号
Sub 返回光标所在行号()
Range("A1") = Selection.Row
VBA返回公式结果
Sub VBA返回公式结果()
x = Application.WorksheetFunction.Sum(Range("a2:a100"))
Range("B1") = x
按照当前行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).Select
当前行下插入1行
Sub 当前行下插入1行()
Selection.Offset(1, 0).Insert
取消指定行或列的隐藏
Sub 取消隐藏行()
&&& Rows("3:5").Select
&&& Selection.EntireRow.Hidden = False
Sub 取消隐藏列()
&&& Columns("C:F").Select
&&& Selection.EntireColumn.Hidden = False
复制单元格所在行
Sub 复制单元格所在行()
&&& Selection.EntireRow.Copy
复制单元格所在列
Sub 复制单元格所在列()
&&& Selection.EntireColumn.Copy
新建一个工作表
Sub 新建一个工作表()
&&& Sheets.Add
新建一个工作簿
Sub 新建一个工作簿()
&&& Workbooks.Add
选择多表为工作组
Sub 选择多表为工作组()
Dim Wks As Worksheet, shtCnt As Integer
Dim arr() As Variant, i As Integer, m As Integer, m1 As Integer, m2 As Integer
shtCnt = ThisWorkbook.Sheets.Count '取得工作表总数
ReDim arr(1 To shtCnt) '预定义数组
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 + 1
If m2 & m1 Then '如果存在符合条件的工作表名称
&&& ReDim Preserve arr(1 To i) '重定义数组
&&& ThisWorkbook.Sheets(arr).Select '选中符合条件的所有工作表
在当前工作组各表中分别执行指定宏
Sub 在当前工作组各表中分别执行指定宏()
Dim SH As Worksheet
For Each SH In ActiveWindow.SelectedSheets
SH.Activate
&&& '临时宏中原录制代码ActiveWorkbook.Names.Add Name:="临时", RefersToR1C1:="=Sheet1!R1C1"&&&&& '插入名称准备返回使用
&&& '临时宏经修改后的代码ActiveWorkbook.names.Add Name:="临时", RefersToR1C1:="=" + ActiveSheet.Name + "!R1C1"&&&& '插入名称准备返回使用
& '其中指定宏代码一定要避免执行工作表的Select方法
Dim SelShts As Sheets
Dim Sht As Worksheet
Sub 在当前工作组各表中分别执行指定宏()
&&& Set SelShts = ActiveWindow.SelectedSheets
&&& For Each Sht In SelShts
&&&&&& Call 临时
复制当前工作簿的报表到临时工作簿
Sub 复制当前工作簿的报表到临时工作簿()
'作者：yuanzhuping版主
Dim x As Integer
Dim sht As Worksheet
On Error Resume Next
For x = 1 To Workbooks.Count
&&& If Workbooks(x).Name = "临时.xls" Then
&&&&&&& For Each sht In Workbooks(x).Sheets
&&&&&&& If sht.Name = "001" Then
&&&&&&&&&&& MsgBox "已经有了001表", 64, "提示"
&&&&&&&&&&&&&&&&
&&&&&&&&&&& Exit Sub
&&&&&&& End If
&&&&&&& Sheets("报表").Copy Before:=Workbooks("临时.xls").Sheets(1)
&&&&&&&&&&& ActiveSheet.Name = "001"
&&&&&&& Exit Sub
&&& End If
&&& Workbooks.Add
&&& ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "临时"
&&& ThisWorkbook.Activate
&&& Sheets("报表").Copy Before:=Workbooks("临时.xls").Sheets(1)
&&& ActiveSheet.Name = "001"
需求说明：
'复制当前工作簿的“报表”工作表到“临时”工作簿为“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"
合并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 = 100
Sub 自动重算()
&&& With Application
&&&&&&& .Calculation = xlAutomatic
&&& End With
Sub 手动重算()
&&& With Application
&&&&&&& .Calculation = xlManual
&&& End With
TA的推荐TA的最新馆藏[转]&[转]&[转]&[转]&[转]&[转]&[转]&[转]&[转]&[转]&[转]&[转]&
喜欢该文的人也喜欢