excel常用宏集合

65：删除包含固定文本单元的行或列
Sub 删除包含固定文本单元的行或列()
Do
(what:="哈哈").Activate
'删除行
' '删除列
Loop Until (what:="哈哈") Is Nothing
End Sub
72：在指定颜色区域选择单元时添加/取消"√"（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myrg As Range
For Each myrg In Target
If = 37 Then myrg = IIf(myrg <> "√", "√", "")
Next
End Sub
73：在指定区域选择单元时添加/取消"√"（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As Range
If <= 15 Then
If Not (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
End Sub
74：双击指定单元，循环录入文本（工作表代码）
Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)
If <> "$A$1" Then Exit Sub
Cancel = True
T = IIf(T = "好", "中", IIf(T = "中", "差", "好"))
End Sub
75：双击指定单元，循环录入文本（工作表代码）
Dim nums As Byte
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If = "$A$1" Then
nums = nums Mod 3 + 1
Target = Mid("上中下", nums, 1)
(1, 0).Select
End If
End Sub
76：单元区域引用（工作表代码）
Private Sub Worksheet_Activate()
("A1:B3").Value = ("A1:B3").Value
End Sub
77：在指定区域选择单元时数值加1（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not ([a1:e10], Target) Is Nothing Then
Target = Val(Target) + 1
End If
End Sub
259个常用宏-excelhome(3)
2009-08-15 14:12:58
78：混合文本的编号
Sub 混合文本的编号()
Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3, 100)) + 1) End Sub
79：指定区域单元双击数据累加（工作表代码）
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not ([A1:Y100], Target) Is Nothing Then
oldvalue = Val
inputvalue = InputBox("请输入数量,按ENTER键确认!", "数值累加器")
= oldvalue + inputvalue
End If
End Sub
80：选择单元区域触发事件（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If = "$A$1:$B$2" Then
MsgBox "你选择了$A$1:$B$2单元"
End If
End Sub
81：当修改指定单元内容时自动执行宏（工作表代码）
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Target, [B3:B4]) Is Nothing Then
重排窗口
End If
End Sub
82：被指定单元内容限制执行宏
Sub 被指定单元限制执行宏()
If Range("$A$1") = "关闭" Then Exit Sub
窗口
End Sub
83：双击单元隐藏该行（工作表代码）
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Rows.Hidden = True
End Sub
84：高亮显示行（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
= 2
Rows("1:2"). = 40 '保持1至2行的颜色推荐39,22,40,
Rows. = 35 '高亮推荐颜色35,20,24,34,37,40,15
End Sub
85：高亮显示行和列（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
= xlNone
Rows. = 34
Columns. = 34
End Sub
86：为指定工作表设置滚动范围（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) = "A1:M30"
End Sub
87：在指定单元记录打印和预览次数（工作簿代码）
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Range("A1") = 1 + Range("A1")
End Sub
88：自动数字金额转大写（工作表代码）
Private Sub Worksheet_Change(ByVal M As Range)
On Error Resume Next
y = Int(Round(100 * Abs(M)) / 100)
j = Round(100 * Abs(M) + - y * 100
f = (j / 10 - Int(j / 10)) * 10
A = IIf(y < 1, "", (y, "[DBNum2]") & "元")
b = IIf(j > , (Int(j / 10), "[DBNum2]") & "角", IIf(y < 1, "", IIf(f > 1, "零", "")))
c = IIf(f < 1, "整", (Round(f, 0), "[DBNum2]") & "分")
M = IIf(Abs(M) < , "", IIf(M < 0, "负" & A & b & c, A & b & c))
End Sub
89：将所有工作表的A1单元作为单击按钮（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If = "$A$1" Then
Call 宏名
End If
End Sub
90：闹钟——到指定时间执行宏（工作簿代码）
Private Sub Workbook_Open()
("11:45:00"), "提示1" '宏名字
("12:00:00"), "提示2" '宏名字
End Sub
91：改变Excel界面标题的宏（工作簿代码）
Private Sub Workbook_Open()
= "春节快乐"
End Sub
92：在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Worksheets("表2").Range("A1") = (0, 0)
End Sub
93：B列录入数据时在A列返回记录时间（工作表代码）
Public Sub Worksheet_Change(ByVal Target As Range)
If = 2 Then
(, -1) = Now
End If
End Sub
94：当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）
Public Sub Worksheet_Change(ByVal Target As Range)
If Not (Target, [A1:A1000]) Is Nothing Then
If = 1 Then
(, 1) = Date
(, 2) = Time
End If
End If
End Sub
Public Sub Worksheet_Change(ByVal Target As Range)
If Not (Target, [A1:A1000]) Is Nothing Then
If = 1 Then
(, 1) = Format(Now(), "yyyy-mm-dd")
(, 2) = Format(Now(), "h:mm:ss")
End If
End If
End Sub
95：指定单元显示光标位置内容（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal T As Range) Sheets(1).Range("A1") = Selection
End Sub
96：每编辑一个单元保存文件
Private Sub Worksheet_Change(ByVal Target As Range) End Sub
97：指定允许编辑区域
Sub 指定允许编辑区域()
= "B8:G15"
End Sub
98：解除允许编辑区域限制
Sub 解除允许编辑区域限制()
= ""
End Sub
99：删除指定行
Sub 删除指定行()
Workbooks("临时表").Sheets("表2").Range("5:5").Delete End Sub
100：删除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
101：删除A列非数字单元行
Sub 删除A列非数字单元行()
i = [a65536].End(xlUp).Row
Range("A1:A" & i).SpecialCells(xlCellTypeConstants, 2). End Sub
102：有条件删除当前行
Sub 有条件删除当前行()
If [A1] = 2 Or [B1] = "删除" Then
Shift:=xlUp
End If
End Sub
103：选择下一行
Sub 选择下一行()
(1, 0).Rows("1:1").
End Sub
104：选择第5行开始所有数据行
Sub 选择第5行开始所有数据行A()
Dim i%
i = ("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).
Rows("5:" & i).Select
End Sub
Sub 选择第5行开始所有数据行B()
Rows("5:" & ("*", , , , 1, 2).Row).Select
End Sub
105：选择光标或选区所在行
Sub 选择光标或选区所在行()
Sub
106：选择光标或选区所在列
Sub 选择光标或选区所在列()
Sub
107：光标定位到名称指定位置
Sub 定位()
Range(Evaluate("名称"))
End Sub
108：选择名称定义的数据区
Sub 选择名称定义的数据区()
[数据区].Select '插入名称要使用INDIRECT函数
'Range("数据区").Select 或者
'("数据区").Select 或者
End Sub
109：选择到指定列的最后行
Sub 选择到指定列的最后行()
Range("C4:G" & [G65536].End(xlUp).Row).Select
End Sub
110：将Sheet1的A列的非空值写到Sheet2的A列
Sub 将Sheet1的A列的非空值写到Sheet2的A列() ("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1] End Sub
111：将名称1的数据写到名称2
Sub Macro2()
Range("位置2") = Range("位置1").Value
End Sub
112：单元反选
Sub 单元反选()
= False
= False
Dim raddress As String, taddress As String
raddress =
taddress =
.Range(taddress) = 0
.Range(raddress) = "=0"
raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address .Delete
End With
(raddress).Select
= True
End Sub
113：调整选中对象中的文字
Sub 调整选中对象中的文字()
'文字居中：自动调整大小
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
.Orientation = xlHorizontal
.AutoSize = True
.AddIndent = False
End With
End Sub
114：去除指定范围内的对象
Sub 去除指定范围内的对象()
Dim p As Shape
Set My = Worksheets("工作表名")
For Each p In
If Not , Range("范围")) Is Nothing Then Next
End Sub
115：更新透视表数据项
Sub DeleteMissingItems2002All()
'防止数据透视表中显示无用的数据项
'在Excel 2002 或更高版本中
'假如无用的数据项已经存在,
'运行这个宏可以更新
Dim pt As PivotTable
Dim ws As Worksheet
For Each ws In
For Each pt In
= xlMissingItemsNone
Next pt
Next ws
End Sub
116：将所有工作表名称写到A列
Sub 将所有表名称写到A列()
k = 1
For Each Sht In Sheets
Cells(k + 1, 1) = '指定写入的行和列
k = k + 1
Next
End Sub
117：为当前选定的多单元插入指定名称
Sub 为当前选定的多单元插入指定名称()
= "临时"
Name:="临时", RefersTo:=Selection '或者换用这行代码也可以End Sub
118：删除所有名称
Sub 删除所有名称()
On Error Resume Next
Dim l As Integer
l = i = l To 1 Step -1
(i).Delete
Next
End Sub
119：以指定区域为表目录补充新表
Sub 以指定区域为表目录补充新表()
Dim dic As Object, sh As Worksheet
Dim arr, item
arr = Range("B1:BB1")
Set dic = CreateObject("")
For Each sh In
, ""
Next
For Each item In arr
If item <> "" And Not (Trim(item)) Then
With .Name = item
End With
End If
Next
Set dic = Nothing
End Sub
120：按A列数据批量修改表名称
Sub 按A列数据批量修改表名称()
Dim i%
For i = 1 To - 1
Sheets(i).Name = Cells(i + 1, 1).Text
Next
End Sub
121：按A列数据批量创建新表(控件按钮代码)
Private Sub CommandButton1_Click()
On Error Resume Next
Dim i%, j%
For i = 1 To [a65536].End(xlUp).Row
For j = 2 To
If Cells(i, 1) = Sheets(j).Name Then
Exit For
End If
Next
(after:=Sheets).Name = Cells(i, 1)
Next
End Sub
122：清除剪贴板
Sub 清除剪贴板()
= False
("Task Pane").Visible = False
End Sub
123：批量清除软回车
Sub 批量清除软回车()
'也可直接使用Alt+10或13替换
What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub
124：判断指定文件是否已经打开
Sub 判断指定文件是否已经打开()
Dim x As Integer
For x = 1 To
If Workbooks(x).Name = "函数.xls" Then '文件名称
MsgBox "文件已打开"
Exit Sub
End If
Next
MsgBox "文件未打开"
End Sub
125：当前文件另存到指定目录
Sub 当前激活文件另存到指定目录()
Filename:="E:\信件\" &
End Sub
126：另存指定文件名
Sub 另存指定文件名()
& "\别名.xls"
End Sub
127：以本工作表名称另存文件到当前目录
Sub 以本工作表名称另存文件到当前目录()
Filename:= & "\" & & ".xls"
End Sub
128：将本工作表单独另存文件到Excel当前默认目录Sub 将本工作表单独另存文件到Excel当前默认目录()
Filename:= & ".xls"
End Sub
129：以活动工作表名称另存文件到Excel当前默认目录
Sub 以活动工作表名称另存文件到Excel当前默认目录() Filename:= & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
End Sub
130：另存所有工作表为工作簿
Sub 另存所有工作表为工作簿()
Dim sht As Worksheet
= False
ipath = & "\"
For Each sht In Sheets
ipath & & ".xls" '(工作表名称为文件名）
' ipath & & Trim(sht.[d15]) & ".xls" '（文件名称& D15单元内容）
' ipath & Trim(sht.[d15]) & ".xls" '（文件名称为D15单元内容）
Next
= True
End Sub
131：以指定单元内容为新文件名另存文件
Sub 以指定单元内容为新文件名另存文件()
Filename:= & "\" & Sheet1.[A1]
End Sub
132：以当前日期为新文件名另存文件
Sub 以当前日期为新文件名另存文件()
& "\" & Format(Now(), "yyyymmdd") & ".xls"
End Sub
Sub 以当前日期为名称另存文件()
Filename:=Date & ".xls"
End Sub
133：以当前日期和时间为新文件名另存文件
Sub 以当前日期和时间为新文件名另存文件()
& "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls"
End Sub
134：另存本表为TXT文件
Sub 另存本表为TXT文件()
Dim s As String
Dim FullName As String, rng As Range
= False
FullName = & ".txt") '以当前表名为TXT文件名
' FullName = Replace, ".xls", ".txt") '以当前文件名为TXT文件名
' FullName = Replace, ".xls", & ".txt") '以文件名&表名为TXT文件名
Open FullName For Output As #1 '以读写方式打开文件，每次写内容都会覆盖原先的内容
'参考帮助，fullname为文件全名
For Each rng In Range("a1").CurrentRegion
s = s & IIf(s = "", "", "|") &
If = Range("a1"). Then
Print #1, s & "|" '把数据写到文本文件里
s = ""
End If
Next
Close #1 '关闭文件
= True
MsgBox "数据已导入文本"
End Sub
135：引用指定位置单元内容为部分文件名另存文件
Sub 引用指定位置单元内容为部分文件名另存文件() Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls" End Sub
136：将A列数据排序到D列
Sub 将A列数据排序到D列()
[d:d] = [a:a].Value
[d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes End Sub
137：将指定范围的数据排列到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 (arr1)
i = i + 1
arr2(i, 1) = x
Next x
Range("D1").Resize(i, 1) = arr2
End Sub
光标移动
Sub 光标移动()
(1, 2).Select '向下移动1行，向右移动2列
End Sub
138：光标所在行上移一行
Sub 光标所在行上移一行()
Dim i%
i = Split, "$")(2)
If i > 1 Then
Rows(i).Cut
Rows(i - 1).Insert Shift:=xlDown
End If
End Sub
139：加数据有效限制
Sub 加数据有效限制()
With
.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
End Sub
140：取消数据有效限制
Sub 取消数据有效限制()
With
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = False
.InCellDropdown = False
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
End Sub
141：重排窗口
Sub 重排窗口()
("Web").Visible = False
("我的工具").Visible = False
ArrangeStyle:=xlCascade
End Sub
142：按当前单元文本选择打开指定文件单元
Sub 选择打开文件单元()
Dim a
a =
Range(a).
Range(a).Select
End Sub
143：回车光标向右
Sub 录入光标向右()
= xlToRight
End Sub
144：回车光标向下
Sub 录入光标向下()
= xlDown
End Sub
145：保护工作表时取消选定锁定单元
Sub 取消选定锁定单元()
= xlUnlockedCells '用于2000版End Sub
146：保存并退出Excel
Sub 保存并退出Excel() ("{ENTER}{ENTER}%fx")
End Sub
147：隐藏/显示指定列空值行
Sub 隐藏显示E列空值行()
Range("E1:E1000").SpecialCells(xlCellTypeBlanks). = Not (Range("E1:E1000").SpecialCells(xlCellTypeBlanks).
End Sub
148：深度隐藏指定工作表
Sub 深度隐藏指定工作表()
Sheets("用户名密码").Visible = xlVeryHidden
End Sub
149：隐藏指定工作表
Sub 隐藏指定工作表()
Sheets("用户名密码").Visible = false
End Sub
150：隐藏当前工作表
Sub 隐藏当前工作表()
= false
End Sub
151：返回当前工作表名称
Sub 返回当前工作表名称()
wsName =
MsgBox "当前工作表为：" & wsName
End Sub
152：获取上一次所进入工作簿的工作表名称
Sub 获取上一次所进入工作簿的工作表名称()
MsgBox Workbooks(2).
End Sub
153：按光标选定颜色隐藏本列其他颜色行
Sub 按颜色筛选() '思路就是:其它背景色之行所有隐藏
Dim UseRow, AC, i '首先选择一个有颜色之单元格，然后动行宏，其它颜色所在行隐藏UseRow = (xlCellTypeLastCell).Row 'SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格
If > UseRow Then
MsgBox "请在要筛选的区域选择一个有颜色之单元格！", vbExclamation, "错误"
Else
AC =
= False '显示所有行
For i = 2 To UseRow
If Cells(i, AC). <> Then
Cells(i, AC). = True '假如2至已用行之单元格的有列之颜色不等于当前单元格颜色则隐藏整行End If
Next
End If
End Sub
154：打开工作簿自动隐藏录入表以外的其他表
Private Sub Workbook_Open()
Dim i
For i = 1 To
If Sheets(i).Name <> "录入" Then
Sheets(i).Visible = False
End If
Next
End Sub
155：除最左边工作表外深度隐藏所有表
Sub 除最左边工作表外深度隐藏所有表()
For i = 2 To Sheets(i).Visible = xlSheetVeryHidden
Next
End Sub
156：关闭文件时自动隐藏指定工作表(ThisWorkbook) Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheets("Sheet2").Visible = False
Sheets("Sheet3").Visible = False
Structure:=True, Windows:=False
End Sub
157：打开文件时提示指定工作表是保护状态(ThisWorkbook)
Private Sub Workbook_Open()
If Worksheets("Sheet1").ProtectContents = True Then
MsgBox " Sheet1 保护了."
End If
End Sub
158：插入10行
Sub 插入10行()
Rows & ":" & + 9).Select
Shift:=xlDown
End Sub
159：全选固定范围内小于0的单元
Sub 全选固定范围内小于0的单元()
Dim rng As Range
Dim yvhf
For Each rng In Range("d6: i18")
If rng < 0 Then
yvhf = yvhf & & ","
End If
Next
Range(Left(yvhf, Len(yvhf) - 1)).Select
End Sub
160：全选选定范围内小于0的单元
Sub 全选选定范围内小于0的单元()
Dim rng As Range
Dim yvhf
For Each rng In Selection
If rng < 0 Then
yvhf = yvhf & & ","
End If
Next
Range(Left(yvhf, Len(yvhf) - 1)).Select
End Sub
161：固定区域单元分类变色
Sub 单元分类变色()
Dim rng As Range
For Each rng In Range("d6: i18")
If rng < 0 Then
= 4 '小于0的单元变绿底色
End If
Next
For Each rng In Range("d6: i18")
If rng > 0 Then
= 3 '文本：假空和大于0的单元变红底色End If
Next
For Each rng In Range("d6: i18")
If rng = 0 Then
= 2 '空值和等于0的单元变白底色
End If
Next
End Sub
162：A列半角内容变红
Sub A列半角内容变红()
Dim rg As Range, i As Long
= False
For Each rg In (xlCellTypeConstants, 3)
For i = 1 To Len(rg)
If Asc(Mid(rg, i, 1)) > 0 Then (i). = 3
Next
Next
= True
End Sub
163：单元格录入数据时运行宏的代码
Private Sub Worksheet_Change(ByVal Target As Range)
重排窗口
End Sub
焦点到A列时运行宏的代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If = 1 Then
宏名
End If
End Sub
164：根据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
Else
Exit For
End If
Next j
Next i
End Sub
165：在F1单元显示光标位置批注内容的代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
a =
b = Range(a).NoteText
Cells(1, 6) = b
End Sub
166：显示光标所在单元的批注的代码
Dim r As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
= False
Set r = Target
= True
End Sub
167：使单元内容保持不变的工作表代码
Private Sub Worksheet_Change(ByVal Target As Range)
[B2] = "不可更改的数据"
End Sub
168：有条件执行宏
Sub 高级筛选()
If [J1] = 2 Or [K1] = "筛选" Then
Columns("D:E").Select
Range("D1").Select
Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _ "G1:G2"), CopyToRange:=Range("D1"), Unique:=False
End If
End Sub
169：有条件执行不同的宏
Sub 有条件执行不同的宏()
If [b1].Value = "A" Then
"宏1"
ElseIf [b1].Value = "B" Then
"宏2"
End If
End Sub
259个常用宏-excelhome(4)
2009-08-15 14:14:17 170：提示确定或取消执行宏
Sub 提示确定或取消执行宏()
If vbOK = MsgBox("确定要复制吗", vbOKCancel) Then Range("A4:A14").Copy Range("b4:b14")
Msgbox "复制结束"
End If
End Sub
171：提示开始和结束
Sub 提示结束()
Msgbox "运行开始"
过程……
Msgbox "运行结束"
End Sub
172：拷贝指定表不相邻多列数据到新位置
Sub 拷贝指定表不相邻多列数据到新位置() Sheets("sheet1").Range("A:A,J:J").Copy Range("d1") End Sub
173：选择2至4行
Sub 选择2至4行()
Dim a As Integer
Dim b As Integer
a = 2
b = 4
Rows(a & ":" & b).Select
End Sub
174：在当前选区有条件替换数值为文本
Sub 在当前选区有条件替换数值为文本()
For Each r In Selection
If > 18 And < Then = "Y"
Next
End Sub
175：自动筛选所有显示指定列
Sub 自动筛选所有显示指定列() Field:=1
Field:=2
Field:=3
Field:=4
Field:=5
Field:=6
End Sub
176：自动筛选第2列值为A的行
Sub 自动筛选第2列值为A的行() [a1].AutoFilter 2, "a"
End Sub
177：取消自动筛选()
Sub 取消自动筛选()
= False
End Sub
178：所有显示指定表的自动筛选
Sub 所有显示指定表的自动筛选()
If = True Then
End If
End Sub
179：强行合并单元
Sub 强行合并单元()
= False '不出现对话框，按对话框默认选择
Range("a3:a4").Merge
= True
End Sub
180：设置单元区域格式
Sub 设置单元区域格式()
[a:a].NumberFormat = ""
Sheet2.[B:B].NumberFormatLocal = "yyyy-m-d"
Sheet2.[C:C].NumberFormatLocal = "G/通用格式" End Sub
181：在所有工作表的A1单元返回顺序号
Sub 在所有工作表的A1单元返回顺序号()
For i = 1 To
Sheets(i).Cells(1, 1) = "'" & + i, "000")
End Sub
182：根据A1单元内容返回C1数值
Sub 根据A1单元内容返回C1数值()
If Range("A1") = "A" Then
Range("C1").FormulaR1C1 = "结算"
ElseIf Range("A1") = "B" Then
Range("C1").FormulaR1C1 = "合计"
ElseIf Range("A1") = "C" Then
Range("C1").FormulaR1C1 = "部门"
End If
End Sub
183：根据A1内容选择执行宏
Sub 根据A1内容选择执行宏()
Select Case Sheet1.[A1]
Case "A"
宏1
Case "B"
宏2
Case "C"
宏3
Case Else
End Select
184：删除A列空行
Sub 删除A列空行()
Columns(1).SpecialCells(xlCellTypeBlanks). End Sub
185：在A列产生不重复随机数
Sub 在A列产生不重复随机数()
Randomize Timer
Dim c(100) As Byte
For i = 1 To 100 '产生100个随机数
c(i) = i
Next
k = 100
Do While l < 100
r = Int(Rnd() * k) + 1 '随机数的范围
aa = c(r)
c(r) = c(k)
c(k) = aa
k = k - 1
l = l + 1
Cells(l, 1) = aa
Loop
End Sub
186：将A列数据随机排列到F列
Sub 将A列数据随机排列到F列()
Dim n As Long
n = [a65536].End(xlUp).Row
[f1].Resize(n, 1) = [a1].Resize(n, 1).Value
[g1].Resize(n, 1) = "=rand()"
[f:g].Sort [g1]
[g:g] = ""
End Sub
187：取消选定区域的公式只保留值(假空转真空)
Sub 取消选定区域的公式只保留值()
' Sheets("数据归并集中").Select '指定工作表
' Columns("Q:R").Select '指定范围
=
End Sub
188：处理导入的显示为科学计数法样式的身份证号
Sub 处理导入的显示为科学计数法样式的身份证号() =
End Sub
189：返回指定单元的行高和列宽
Sub 返回指定单元的行高和列宽()
[c2] = Range("A1").ColumnWidth '列宽
[b2] = Range("A1").RowHeight '行高
End Sub
Sub 返回指定单元的行高和列宽()
Dim r%, c%
r = [a1].RowHeight
c = [a1].ColumnWidth
[b2] = r '行高
[c2] = c '列宽
End Sub
190：指定行高和列宽
Sub 指定行高和列宽()
Range("A1:F1").ColumnWidth = 10 '指定列宽
Range("A2:A10").RowHeight = 40 '指定行高End Sub
Sub 指定行高和列宽()
Columns("A:F").ColumnWidth = 10 '指定列宽
Rows("2:10").RowHeight = 40 '指定行高End Sub
191：指定单元的行高和列宽与A1单元相同
Sub 指定单元的行高和列宽与A1单元相同()
Range("A1:F1").ColumnWidth = Range("A1").ColumnWidth '指定列宽Range("A2:A10").RowHeight = Range("A1").RowHeight '指定行高End Sub
191：填公式
Sub 填公式()
Range("C2:C12").Value = "=SUM(A2:B2)"
End Sub
192：建立当前工作表的副本为001表
Sub 建立当前工作表的副本为001表()
Before:=Sheets(1)
= "001"
End Sub
193：在第一个表前插入多工作表
Sub 在第一个表前插入多工作表()
Sheets(1).Select
For I = 1 To 50
= "新表" & I
Next
End Sub
194：清除A列再插入序号
Sub 清除A列再插入序号()
'Columns(1).ClearContents '清除A列内容
For i = 1 To 20
Range("a" & i) = i
Next
End Sub
195：反方向文本(自定义函数)
Function zhyz(zhyz1 As Range)
zhyz = StrReverse(zhyz1)
End Function
将代码复制到模块后单元公式：=zhyz(单元格)
196：指定选择单元区域弹出消息
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If = "$A$1:$C$3" Then
MsgBox "你选择对了"
End If
End Sub
197：将B列数据添加超链接到K列
Sub 将B列数据添加超链接到K列()
For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)
Anchor:=Rng, Address:="", SubAddress:=("K" & .Address, ScreenTip:="点击转到:" & & "K" &
Next
End Sub
198：删除B列数据的超链接
Sub 删除超链接()
For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)
.
Next
End Sub
199：分离临时表A列数据的文本和超链接并整理到数据库表
Sub 分离A列中的超链接到指定表的B和C列()
i = Worksheets("数据库").Range("b60000").End(xlUp).Row
For Each h In Worksheets("临时").Hyperlinks
Worksheets("数据库").Cells(i + 1, 2) =
Worksheets("数据库").Cells(i + 1, 3) =
Range(Worksheets("数据库").Cells(i + 1, 3), Worksheets("数据库").Cells(i + 1, 3)). Anchor:=Cells(i + 1, 3), Address:=Cells(i + 1, 3)
i = i + 1
Next
End Sub
200：分离临时表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 = Cells(ee, 1) And Cells(ee, 1) <> "" Then
www = www & "," & ee
End If
Next
Next
www = Right(www, Len(www) - 1)
zxc = Split(www, ",")
For sd = 0 To UBound(zxc) - 1
For wee = zxc(sd) + 1 To zxc(sd + 1) - 1
Worksheets("数据库").Cells(sdf + ier + 1, uu + 4) = Cells(wee, 1)
uu = uu + 1
Next
sdf = sdf + 1
uu = 0
Next
For Each hhh In Worksheets("临时").Range("A6:A6000").Hyperlinks
Worksheets("数据库").Cells(ier + 1, 2) =
Worksheets("数据库").Cells(ier + 1, 3) =
Range(Worksheets("数据库").Cells(ier + 1, 3), Worksheets("数据库").Cells(ier + 1, 3)). Anchor:=Worksheets("数据库").Cells(ier + 1, 3), Address:=Worksheets("数据库").Cells(ier + 1, 3) ier = ier + 1
Next
End Sub
201：返回A列最后一个非空单元行号
Sub 返回A列最后非空单元行号()
MsgBox ("A65536").End(xlUp).Row
End Sub
202：返回表中第一个非空单元地址(行搜索)
Sub 返回表中第一个非空单元地址()
MsgBox ("*").Address
End Sub
203：返回表中各非空单元区域地址(行搜索)
Sub 返回表中各非空单元区域地址()
MsgBox (2).Address
End Sub
204：返回第一个数值行号
Sub 返回第一个数值行号()
MsgBox [b:b].SpecialCells(2, 1).Row
End Sub
205：返回第1行最右边非空单元的列号
Sub 返回第1行最右边非空单元的列号()
X = [IV1].End(xlToLeft).Column
MsgBox X
End Sub
206：返回连续数值单元的数量
Sub 返回连续数值单元的数量()
MsgBox [b:b].SpecialCells(2, 1).
End Sub
207：统计指定范围和内容的单元数量
Sub 统计指定范围和内容的单元数量()
x = "A3:B100"), "总计")
Range("B1") = x
End Sub
208：统计不同颜色的数字的和（自定义函数）
Public Function COLOR(ByVal X As Range, Y)
For Each I In X
If = Y Then
COLOR = COLOR + I
End If
Next I
End Function
'统计红色,输入：=COLOR(B2:B8,3)
'统计蓝色,输入：=COLOR(B2:B8,5)
209：返回非空单元数量
Sub 返回非空单元数量()
x = (Range("A1:Z65536"))
MsgBox x
End Sub
210：返回A列非空单元数量
Sub 返回A列非空单元数量()
y = (Columns(1))
MsgBox y
End Sub
211：返回圆周率π
Sub Macro1()
Range("A1") = ()
End Sub
212：定义指定单元内容为页眉/页脚
Sub 定义指定单元内容为页眉/页脚() BBB = Sheets("表1").Range("A2")
With
.CenterHeader = BBB '定义页眉
' .CenterFooter = BBB '定义页脚
End With
End Sub
213：提示并所有清除当前选择区域
Sub 提示并所有清除当前选择区域()
If MsgBox("你确定要清除选择的区域吗", vbYesNo, " 提示:") = vbYes Then End Sub
214：所有清除当前选择区域
Sub 所有清除当前选择区域()
' Range("A1:B10").Clear '所有清除指定区域
End Sub
215：清除指定区域数值
Sub 清除单元数值()
Sheet1.[A1:A10].ClearContents
End Sub
Sub 清除指定区域数值()
Range("A1:C8") = ClearContents。