Excel屏蔽代码大全
EXCEL 常用的宏代码大全
EXCEL 常用的宏代码大全本示例为设置密码窗口(1)If Application.InputBox("请输入密码：") = 1234 Then[A1] = 1 '密码正确时执行Else: MsgBox "密码错误，即将退出！" '此行与第2行共同设置密码End If本示例为设置密码窗口(1)X = MsgBox("是否真的要结帐？", vbYesNo)If X = vbYes ThenClose本示例为设置工作表密码ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码ActiveSheet.Unprotect Password:=641112 '撤消工作表保护并取消密码'本示例关闭除正在运行本示例的工作簿以外的其他所有工作簿，并保存其更改内容。
For Each w In WorkbooksIf <> Thenw.Close SaveChanges:=TrueEnd IfNext w'每次打开工作簿时，本示例都最大化Microsoft Excel 窗口。
Application.WindowState = xlMaximized'本示例显示活动工作表的名称。
MsgBox "The name of the active sheet is " & '本示例保存当前活动工作簿的副本。
ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS"'下述过程激活工作簿中的第四张工作表。
Sheets(4).Activate'下述过程激活工作簿中的第1张工作表。
Worksheets(1).Activate'本示例通过将Saved 属性设为True 来关闭包含本段代码的工作簿，并放弃对该工作簿的任何更改。
Excel-vba宏代码-大全
宏文件集▲打开全部隐藏工作表返回Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = TrueNext iEnd Sub▲循环宏返回Sub 循环()AAA = Range("C2")Dim i As LongDim times As Longtimes = AAA'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range("完成标志") = "完成" Then Exit For '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则只执行一次循环就退出'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For '如果某列出现"完成"内容则退出循环Next iEnd Sub▲录制宏时调用“停止录制”工具栏返回Sub 录制宏时调用停止录制工具栏()mandBars("Stop Recording").Visible = TrueEnd Sub▲高级筛选5列不重复数据至指定表返回Sub 高级筛选5列不重复数据至Sheet2()Sheets("Sheet2").Range("A1:E65536") = "" '清除Sheet2的A:D列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _"A1"), Unique:=TrueSheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"), Order1:=xlAscending,Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub▲双击单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$4"Call 宏1Cancel = TrueCase "$B$4"Call 宏2Cancel = TrueCase "$C$4"Call 宏3Cancel = TrueCase "$E$4"Call 宏4Cancel = TrueEnd SelectEnd Sub▲双击指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubIf 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 SubSelect Case Target.AddressCase "$A$5" '单元地址(Target.Address),或命名单元名字()Call 宏1Case "$B$5"Call 宏2Case "$C$5"Call 宏3End SelectEnd Sub▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call打开隐藏表End Sub▲在多个宏中依次循环执行一个（控件按钮代码）返回Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub▲在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()With CommandButton1If .Caption = "保护工作表" ThenCall 保护工作表.Caption = "取消工作表保护"Exit SubEnd IfIf .Caption = "取消工作表保护" ThenCall 取消工作表保护.Caption = "保护工作表"Exit SubEnd IfEnd WithEnd Sub▲在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = "宏1" ThenCall 宏1.Caption = "宏2"Exit SubEnd IfIf .Caption = "宏2" ThenCall 宏2.Caption = "宏3"Exit SubEnd IfIf .Caption = "宏3" ThenCall 宏3.Caption = "宏1"Exit SubEnd IfEnd WithEnd Sub▲根据A1单元文本隐藏/显示按钮（控件按钮代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("A1") > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub▲当前单元返回按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub▲当前单元内容返回到按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub▲奇偶页分别打印返回Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数MsgBox "现在打印奇数页,按确定开始."For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox "现在打印偶数页,按确定开始."For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub▲自动打印多工作表第一页返回Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx = InputBox("请输入起始工作表名字:")sy = InputBox("请输入结束工作表名字:")y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub▲查找A列文本循环插入分页符返回Sub 循环插入分页符()' Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页")'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub▲将A列最后数据行以上的所有B列图片大小调整为所在单元大小返回Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing ThenPic.Top = Pic.TopLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub▲返回光标所在行数返回Sub 返回光标所在行数()x = ActiveCell.RowRange("A1") = xEnd Sub▲在A1返回当前选中单元格数量返回Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub▲返回当前工作簿中工作表数量返回Sub 返回当前工作簿中工作表数量()t = Application.Sheets.CountMsgBox tEnd Sub▲返回光标选择区域的行数和列数返回Sub 返回光标选择区域的行数和列数()x = Selection.Rows.County = Selection.Columns.CountRange("A1") = xRange("A2") = yEnd Sub▲工作表中包含数据的最大行数返回Sub 包含数据的最大行数()n = Cells.Find("*", , , , 1, 2).RowMsgBox nEnd Sub▲返回A列数据的最大行数返回Sub 返回A列数据的最大行数()n = Range("a65536").End(xlUp).RowRange("B1") = nEnd Sub▲将所选区域文本插入新建文本框返回Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left +ActiveCell.Width, ActiveCell.Top + ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = "问题：" & nWith Selection.Characters(Start:=1, Length:=3).Font.Name = "黑体".FontStyle = "常规".Size = 12End WithEnd Sub▲批量插入地址批注返回Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionment.Deleter.AddCommentment.Visible = Falsement.Text Text:="本单元格：" & r.Address & " of " & Selection.AddressNextEnd IfEnd Sub▲批量插入统一批注返回Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=msgNextEnd IfEnd Sub▲以A1单元内容批量插入批注返回Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=[a1].TextNextEnd IfEnd Sub▲不连续区域插入当前文件名和表名及地址返回Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = "[" + + "]" + +"!" + mycell.AddressNextEnd Sub▲不连续区域录入当前单元地址返回Sub 区域录入当前单元地址()For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub▲连续区域录入当前单元地址返回Sub 连续区域录入当前单元地址()Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub▲返回当前单元地址返回Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub▲不连续区域录入当前日期返回Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")End Sub▲不连续区域录入当前数字日期返回Sub 区域录入当前数字日期()Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")End Sub▲不连续区域录入当前日期和时间返回Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")End Sub▲不连续区域录入对勾返回Sub 批量录入对勾()Selection.FormulaR1C1 = "√"End Sub▲不连续区域录入当前文件名返回Sub 批量录入当前文件名()Selection.FormulaR1C1 = End Sub▲不连续区域添加文本返回Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & "文本内容"NextEnd Sub▲不连续区域插入文本返回Sub 批量插入文本()Dim s As RangeFor Each s In Selections = "文本内容" & sNextEnd Sub▲从指定位置向下同时录入多单元指定内容返回Sub 从指定位置向下同时录入多单元指定内容()Dim arrarr = 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 = 1Sheets("aa").SelectDo While Cells(I, 1).Value <> ""str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets("aa").SelectLoopEnd Sub▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add = nmEnd Sub▲删除全部未选定工作表返回Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As BooleanDim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n - 1If ShtName(i) = TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub▲工作表标签排序返回Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox("工作表按升序排列请选 '是[Y]'. " & vbCrLf & vbCrLf & "工作表按降序排列请选 '否[N]'", vbYesNoCancel, "工作表排序")If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then 'Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse 'Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub▲定义指定工作表标签颜色返回Sub 定义指定工作表标签颜色()Sheets("Sheet1").Tab.ColorIndex = 46End Sub▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets("目录").ActivateIf Err = 0 ThenSheets("目录").UsedRange.DeleteElseSheets.Add = "目录"End IfFor i = 1 To Sheets.CountIf Sheets(i).Name <> "目录" Thens = s + 1Set Rng = Sheets("目录").Cells(((s - 1) Mod 20) + 1, (s - 1) \ 20 + 1 + 1)Rng = Format(s, " 0") & ". " & Sheets(i).NameActiveSheet.Hyperlinks.Add Rng, "#" & Sheets(i).Name & "!A1",ScreenTip:=Sheets(i).NameEnd IfNextSheets("目录").Range("b:iv").EntireColumn.ColumnWidth = 20End Sub▲建立工作表文本目录返回Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)Sheets(1).Name = "目录"For i = 2 To Sheets.CountCells(i - 1, 1) = Sheets(i).Name'Sheets(1).Hyperlinks.Add Cells(i - 1, 1), "#" & Sheets(i).Name & "!A1" '添加超链接NextEnd Sub▲查另一文件的全部表名返回Sub 查另一文件的全部表名()On Error Resume NextDim i%Dim sh As WorksheetApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=ThisWorkbook.Path & "\2.xls"Windows("1.xls").Activate '当前文件名称Sheets("Sheet1").Select '当前表名称i = 1 '将表名称返回到第1行For Each sh In Workbooks("2.xls").WorksheetsCells(i, 1) = '将表名称返回到第1列i = i + 1 '返回每个表名称向下移动1行Next shWindows("2.xls").Close '关闭对象文件Application.ScreenUpdating = TrueEnd 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 IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext nEnd Sub▲为指定工作表加指定密码保护表返回Sub 为指定工作表加指定密码保护表()Sheet10.Protect Password:="123"End Sub▲在有密码的工作表执行代码返回Sub 在有密码的工作表执行代码()Sheets("1").Unprotect Password:=123 '假定表名为“1”，密码为“123” 打开工作表Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True '隐藏C列空值行Sheets("1").Protect Password:=123 '重新用密码保护工作表End Sub▲执行前需要验证密码的宏(控件按钮代码)返回Private Sub CommandButton1_Click()If InputBox("请输入密码：") <> "123" Then '密码是123MsgBox "密码错误,按确定退出!", 64, "提示"Exit SubEnd IfCells(1, 1) = 10End SubSub 执行前需要验证密码的宏()If InputBox("请输入您的使用权限:", "系统提示") = 123 Then重排窗口 '要执行的宏代码或宏名称ElseMsgBox "对不起,您没有使用该宏的权限,按确定键后退出!"End IfEnd Sub▲拷贝A1公式和格式到A2返回Sub 拷贝A1公式到A2()Workbooks("临时表").Sheets("表1").Range("A1").CopyWorkbooks("临时表").Sheets("表2").Range("A2").PasteSpecialEnd Sub▲复制单元数值返回Sub 复制数值()s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2")Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = sEnd Sub▲插入数值条件格式返回Sub 插入数值条件格式()Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="70"Selection.FormatConditions(1).Interior.ColorIndex = 45Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _Formula1:="55"Selection.FormatConditions(2).Interior.ColorIndex = 39Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="60"Selection.FormatConditions(3).Interior.ColorIndex = 34End Sub▲插入透明批注返回Sub 插入透明批注()Selection.AddCommentment.Visible = FalseDim XS As WorksheetFor i = 1 To ments.Countments(i).Text "透明批注"ments(i).Shape.Fill.Visible = msoFalseNextEnd Sub▲添加文本返回Sub 添加文本()Selection = Selection + "×" '不可在数字后添加文本'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲光标定位到指定工作表A列最后数据行下一单元返回Sub 光标定位到指定工作表A列最后数据行下一单元()a = Sheets("数据库").[a65536].End(xlUp).RowSheets("数据库").SelectRange("A" & a + 1).SelectEnd Sub▲定位选定单元格式相同的全部单元格返回Sub 定位选定单元格式相同的全部单元格()Dim FirstCell As Range, FoundCell As RangeDim AllCells As RangeWith 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.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.FormulaHiddenEnd WithSet FirstCell = edRange.Find(what:="", searchformat:=True)If FirstCell Is Nothing ThenExit SubEnd IfSet AllCells = FirstCellSet FoundCell = FirstCellDoSet FoundCell = edRange.Find(After:=FoundCell, what:="",searchformat:=True)If FoundCell Is Nothing Then Exit DoSet AllCells = Union(FoundCell, AllCells)If FoundCell.Address = FirstCell.Address Then Exit DoLoopAllCells.SelectEnd Sub▲按当前单元文本定位返回Sub 按当前单元文本定位()ABC = SelectionDim aa As RangeFor Each a In edRangeIf a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲按固定文本定位返回Sub 文本定位()Dim aa As RangeFor Each a In edRangeIf a Like "*合计*" ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲删除包含固定文本单元的行或列返回Sub 删除包含固定文本单元的行或列()DoCells.Find(what:="哈哈").ActivateSelection.EntireRow.Delete '删除行' Selection.EntireColumn.Delete '删除列Loop Until Cells.Find(what:="哈哈") Is NothingEnd Sub▲定位数据及区域以上的空值返回Sub 定位数据及区域以上的空值()Dim aa As RangeFor Each a In edRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲右侧单元自动加5(工作表代码)返回Private Sub Worksheet_Change(ByVal Target As Range)Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd 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 23Cells(i, 1) = Cells(i, 1) - Cells(i, 2)NextEnd Sub▲用于光标选定多区域跳转指定单元(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal T As Range)a = Array([b6:b7], [e6], [h6])For i = 0 To 2If Not Application.Intersect(T, a(i)) Is Nothing Then[a1].Select: Exit ForEnd IfNextEnd Sub▲将A1单元录入的数据累加到B1单元（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)Dim t As LongIf Target.Address = "$A$1" Thent = Sheet1.Range("$B$1").ValueSheet1.Range("$B$1").Value = t + Target.ValueEnd IfEnd Sub▲在指定颜色区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> "√", "√", "")NextEnd Sub▲在指定区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target, Range("D6:D20")) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = "" Then.Value = "√"Else.Value = ""End IfEnd WithNextEnd IfEnd IfEnd Sub▲双击指定单元，循环录入文本（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)If T.Address <> "$A$1" Then Exit SubCancel = TrueT = IIf(T = "好", "中", IIf(T = "中", "差", "好"))End Sub双击指定单元，循环录入文本（工作表代码）Dim nums As BytePrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address = "$A$1" Thennums = nums Mod 3 + 1Target = Mid("上中下", nums, 1)Target.Offset(1, 0).SelectEnd IfEnd Sub▲单元区域引用（工作表代码）返回Private Sub Worksheet_Activate()Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").ValueEnd Sub▲在指定区域选择单元时数值加1（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect([a1:e10], Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub▲混合文本的编号返回Sub 混合文本的编号()Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3,100)) + 1)End Sub▲指定区域单元双击数据累加（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Not Application.Intersect([A1:Y100], Target) Is Nothing Thenoldvalue = Val(Target.Value)inputvalue = InputBox("请输入数量,按ENTER键确认!", "数值累加器")Target.Value = oldvalue + inputvalueEnd IfEnd Sub▲选择单元区域触发事件（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = "$A$1:$B$2" ThenMsgBox "你选择了$A$1:$B$2单元"End IfEnd Sub▲当修改指定单元内容时自动执行宏（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then重排窗口End IfEnd Sub▲被指定单元内容限制执行宏返回Sub 被指定单元限制执行宏()If Range("$A$1") = "关闭" Then Exit Sub窗口End Sub▲双击单元隐藏该行（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Rows(Target.Row).Hidden = TrueEnd Sub▲高亮显示行（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = 2Rows("1:2").Interior.ColorIndex = 40 '保持1至2行的颜色推荐39,22,40,Rows(Target.Row).Interior.ColorIndex = 35 '高亮推荐颜色35,20,24,34,37,40,15End Sub▲高亮显示行和列（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34Columns(Target.Column).Interior.ColorIndex = 34End Sub▲为指定工作表设置滚动范围（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)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 Nexty = Int(Round(100 * Abs(M)) / 100)j = Round(100 * Abs(M) + 0.00001) - y * 100f = (j / 10 - Int(j / 10)) * 10A = 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 AsRange)If Target.Address = "$A$1" ThenCall 宏名End IfEnd 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 AsRange)Worksheets("表2").Range("A1") = Target.Address(0, 0)End Sub▲B列录入数据时在A列返回记录时间（工作表代码）返回Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub▲当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）返回Public Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [A1:A1000]) Is Nothing ThenIf Target.Column = 1 ThenTarget.Offset(, 1) = DateTarget.Offset(, 2) = TimeEnd IfEnd IfEnd SubPublic Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [A1:A1000]) Is Nothing ThenIf Target.Column = 1 ThenTarget.Offset(, 1) = Format(Now(), "yyyy-mm-dd")Target.Offset(, 2) = Format(Now(), "h:mm:ss")End IfEnd IfEnd Sub▲指定单元显示光标位置内容（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal T As Range)Sheets(1).Range("A1") = SelectionEnd Sub▲每编辑一个单元保存文件返回Private Sub Worksheet_Change(ByVal Target As Range)ThisWorkbook.SaveEnd Sub▲指定允许编辑区域返回Sub 指定允许编辑区域()ActiveSheet.ScrollArea = "B8:G15"End Sub▲解除允许编辑区域限制返回Sub 解除允许编辑区域限制()ActiveSheet.ScrollArea = ""End Sub▲删除指定行返回Sub 删除指定行()Workbooks("临时表").Sheets("表2").Range("5:5").DeleteEnd Sub▲删除A列为指定内容的行返回Sub 删除A列为指定内容的行()Dim a, b As Integera = Sheet1.[a65536].End(xlUp).RowFor b = a To 2 Step -1If Cells(b, 1).Value = "删除" ThenRows(b).DeleteEnd IfNextEnd Sub▲删除A列非数字单元行返回Sub 删除A列非数字单元行()i = [a65536].End(xlUp).RowRange("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.DeleteEnd Sub▲有条件删除当前行返回Sub 有条件删除当前行()If [A1] = 2 Or [B1] = "删除" ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub▲选择下一行返回Sub 选择下一行()ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.SelectEnd Sub▲选择第5行开始所有数据行返回Sub 选择第5行开始所有数据行A()Dim i%i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues,SearchDirection:=xlPrevious).EntireRow.RowRows("5:" & i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows("5:" & Cells.Find("*", , , , 1, 2).Row).SelectEnd Sub▲选择光标或选区所在行返回Sub 选择光标或选区所在行()Selection.EntireRow.Select▲选择光标或选区所在列返回Sub 选择光标或选区所在列()Selection.EntireColumn.SelectEnd Sub▲光标定位到名称指定位置返回Sub 定位()Application.Goto Range(Evaluate("名称"))End Sub▲选择名称定义的数据区返回Sub 选择名称定义的数据区()[数据区].Select '插入名称要使用INDIRECT函数'Range("数据区").Select 或者'Sheet1.Range("数据区").Select 或者End Sub▲选择到指定列的最后行返回Sub 选择到指定列的最后行()Range("C4:G" & [G65536].End(xlUp).Row).SelectEnd Sub▲将Sheet1的A列的非空值写到Sheet2的A列返回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▲单元反选返回Sub 单元反选()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress As String, taddress As Stringraddress = Selection.Addresstaddress = edRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = "=0"raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address.DeleteEnd WithActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub▲调整选中对象中的文字返回Sub 调整选中对象中的文字()'文字居中、自动调整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd WithEnd Sub▲去除指定范围内的对象返回Sub 去除指定范围内的对象()。
EXCELWPS VBA宏代码大全
EXCEL/WPS VBA宏代码大全Application.Dialogs(1).Show是调用打开对话框Application.Dialogs(5或145).Show是调用另存为对话框，Application.Dialogs(6).Show是删除文档Application.Dialogs(7).Show是页面设置Application.Dialogs(8).Show是打印对话框Application.Dialogs(9).Show是选择打印机对话框Application.Dialogs(12).Show是重排窗口设置对话框Application.Dialogs(17).Show宏对话框Application.Dialogs(23).Show设置打印标题Application.Dialogs(26).Show字体设置对话框Application.Dialogs(27).Show显示选项Application.Dialogs(28).Show保护工作表Application.Dialogs(32).Show重算选项Application.Dialogs(39或192).Show排序Application.Dialogs(40).Show序列选项Application.Dialogs(41).Show模拟运算表Application.Dialogs(42或111).Show单元格格式，选择单元格内容的格式Application.Dialogs(43).Show选择单元格字体的排列格式，横排或竖排等Application.Dialogs(44或134或190).Show字体选择Application.Dialogs(45).Show边框格式设置Application.Dialogs(46).Show对单元格的保护或隐藏选项Application.Dialogs(47).Show列宽设置选项Application.Dialogs(52).Show清除对话框Application.Dialogs(53).Show选择性粘贴对话框Application.Dialogs(54).Show删除对话框Application.Dialogs(55).Show插入对话框Application.Dialogs(61或110).Show定义名称对话框Application.Dialogs(62).Show指定名称Application.Dialogs(63或132).Show定位Application.Dialogs(64).Show查找Application.Dialogs(84).Show设置单元格颜色和图案Application.Dialogs(91).Show分列Application.Dialogs(94).Show取消或隐藏工作表选择对话框Application.Dialogs(95).Show工作区视图等选项Application.Dialogs(103).Show选择要激活哪个工作表对话框Application.Dialogs(108).Show复制图片选项Application.Dialogs(119).Show新建对话框Application.Dialogs(127).Show设置行高Application.Dialogs(130).Show替换对话框Application.Dialogs(137).Show拆分当前窗口Application.Dialogs(161).Show设置图表颜色Application.Dialogs(170或171).Show移动当前窗口Application.Dialogs(191).Show合并计算对话框Application.Dialogs(198).Show单变量求解Application.Dialogs(199).Show选定成组工作表Application.Dialogs(200).Show填充成组工作表。
Excel宏大全Excel宏大全...
Excel宏大全EXCEL 宏命令大全 ?打开全部隐藏工作表Sub 打开全部隐藏工作表() Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = True Next iEnd Sub循环宏Sub 循环()AAA = Range(“C2″)Dim i As LongDim times As Longtimes = AAA‘times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range(“完成标志”) = “完成” Then Exit For ‘如果名为’完成标志’的命名单元的值等于’完成’,则退出循环,如果一开始就等于’完成’,则只执行一次循环就退出‘If Sheets(“传送参数”).Range(“A” & i).Text = “完成” Then Exit For ’如果某列出现”完成”内容则退出循环Next iEnd Sub录制宏时调用“停止录制”工具栏Sub 录制宏时调用停止录制工具栏()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:=TrueSheet2.Columns(“A:E”).Sort Key1:=Sheet2.Range(“A2″), Order1:=xlAscending, Header:=xlGuess, _OrderCustom:=1, MatchCase:=False,Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub双击单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range(“$A$1″) = “关闭” Then Exit SubSelect Case Target.AddressCase “$A$4″Call 宏1Cancel = TrueCase “$B$4″Call 宏2Cancel = TrueCase “$C$4″Call 宏3Cancel = TrueCase “$E$4″Call 宏4Cancel = TrueEnd SelectEnd Sub双击指定区域单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range(“$A$1″) = “关闭” Then Exit SubIf 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 SubSelect Case Target.AddressCase “$A$5″ ‘单元地址(Target.Address),或命名单元名字()Call 宏1Case “$B$5″Call 宏2Case “$C$5″Call 宏3End SelectEnd Sub进入指定区域单元执行宏(工作表代码)Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range(“$A$1″) = “关闭” Then Exit SubIf Not Application.Intersect(Target,Range(“A4:A9″,”C4:C9″)) Is Nothing Then Call 打开隐藏表End Sub在多个宏中依次循环执行一个（控件按钮代码）Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Private Sub CommandButton1_Click()With CommandButton1If .Caption = “保护工作表” ThenCall 保护工作表.Caption = “取消工作表保护”Exit SubEnd IfIf .Caption = “取消工作表保护” ThenCall 取消工作表保护.Caption = “保护工作表”Exit SubEnd IfEnd WithEnd Sub在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = “宏1″ ThenCall 宏1.Caption = “宏2″Exit SubEnd IfIf .Caption = “宏2″ ThenCall 宏2.Caption = “宏3″Exit SubEnd IfIf .Caption = “宏3″ ThenCall 宏3.Caption = “宏1″Exit SubEnd IfEnd WithEnd Sub根据A1单元文本隐藏/显示按钮（控件按钮代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range(“A1″) > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub当前单元返回按钮名称（控件按钮代码）Private Sub CommandButton1_Click() ActiveCell = CommandButton1.CaptionEnd Sub当前单元内容返回到按钮名称（控件按钮代码）Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub奇偶页分别打印Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro(“GET.DOCUMENT(50)”) ‘总页数MsgBox “现在打印奇数页,按确定开始.”For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox “现在打印偶数页,按确定开始.”For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub自动打印多工作表第一页Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx = InputBox(“请输入起始工作表名字:”) sy = InputBox(“请输入结束工作表名字:”) y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub查找A列文本循环插入分页符Sub 循环插入分页符()‘ Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容Dim i As LongDim times As Longtimes =Application.WorksheetFunction.CountIf(Sheet1.Range(“a:a”), “分页”)‘times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:=”分页”, After:=ActiveCell,LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows,SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.AddBefore:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub将A列最后数据行以上的所有B列图片大小调整为所在单元大小Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range(“B1:B” & i)) Is Nothing ThenPic.Top = Pic.TopLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub返回光标所在行数Sub 返回光标所在行数()x = ActiveCell.RowRange(“A1″) = xEnd Sub在A1返回当前选中单元格数量Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub返回当前工作簿中工作表数量Sub 返回当前工作簿中工作表数量() t = Application.Sheets.Count MsgBox tEnd Sub返回光标选择区域的行数和列数Sub 返回光标选择区域的行数和列数() x = Selection.Rows.County = Selection.Columns.CountR ange(“A1″) = xRang e(“A2″) = yEnd Sub工作表中包含数据的最大行数Sub 包含数据的最大行数()n = Cells.Find(“*”, , , , 1, 2).RowMsgBox nEnd Sub返回A列数据的最大行数Sub 返回A列数据的最大行数()n = Range(“a65536″).End(xlUp).RowRange(“B1″) = nEnd Sub将所选区域文本插入新建文本框Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top +ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = “问题：” & nWith Selection.Characters(Start:=1, Length:=3).Font .Name = “黑体”.FontStyle = “常规”.Size = 12End WithEnd Sub批量插入地址批注Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionment.Deleter.AddCommentment.Visible = Falsement.Text Text:=”本单元格：” & r.Address & ” of ” & Selection.AddressNextEnd IfEnd Sub批量插入统一批注Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox(“请输入欲批量插入的批注”, “提示”, “随便输点什么吧”)If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=msgNextEnd IfEnd Sub以A1单元内容批量插入批注Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 Then For Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=[a1].TextNextEnd IfEnd Sub不连续区域插入当前文件名和表名及地址Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = “[" + + "]” + ActiveS + “!” + mycell.AddressNextEnd Sub不连续区域录入当前单元地址Sub 区域录入当前单元地址()For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub连续区域录入当前单元地址Sub 连续区域录入当前单元地址()Selection = “=ADDRESS(ROW(),COLUMN(),4,1)”Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub返回当前单元地址Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub不连续区域录入当前日期Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), “yyyy-m-d”) End Sub不连续区域录入当前数字日期Sub 区域录入当前数字日期()Selection.FormulaR1C1 = Format(Now(), “yyyymmdd”) End Sub不连续区域录入当前日期和时间Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), “yyyy-m-d h:mm:ss”)End Sub不连续区域录入对勾Sub 批量录入对勾()Selection.FormulaR1C1 = “√”End Sub不连续区域录入当前文件名Sub 批量录入当前文件名()Selection.FormulaR1C1 = End Sub不连续区域添加文本Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & “文本内容”NextEnd Sub不连续区域插入文本Sub 批量插入文本()Dim s As RangeFor Each s In Selections = “文本内容” & sNextEnd Sub从指定位置向下同时录入多单元指定内容Sub 从指定位置向下同时录入多单元指定内容()Dim arrarr = 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 = 1Sheets(“aa”).SelectDo While Cells(I, 1).Value <> “”str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets(“aa”).SelectLoopEnd Sub以A1单元文本作表名插入工作表Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add = nmEnd Sub删除全部未选定工作表Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As Boolean Dim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheets ShtName(n) = n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n – 1If ShtName(i) = TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub工作表标签排序Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox(“工作表按升序排列请选‘是[Y]‘. ” & vbCrLf & vbCrLf & “工作表按降序排列请选‘否[N]‘”, vbYesNoCancel, “工作表排序”)If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then ‘Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) <UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse ‘Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) >UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i) End IfNext jNext iEnd IfEnd Sub定义指定工作表标签颜色Sub 定义指定工作表标签颜色()Sheets(“Sheet1″).Tab.ColorIndex = 46 End Sub在目录表建立本工作簿中各表链接目录Sub 在目录表建立本工作簿中各表链接目录() Dim s%, Rng As RangeOn Error Resume NextSheets(“目录”).ActivateIf Err = 0 ThenSheets(“目录”).UsedRange.Delete ElseSheets.Add = “目录”End IfFor i = 1 To Sheets.CountIf Sheets(i).Name <> “目录” Thens = s + 1Set Rng = Sheets(“目录”).Cells(((s –1) Mod 20) + 1, (s – 1) \ 20 + 1 + 1)Rng = Format(s, ” 0″) & “. ” & Sheets(i).NameActiveSheet.Hyperlinks.Add Rng, “#” &Sheets(i).Name & “!A1″, ScreenTip:=Sheets(i).NameEnd IfNextSheets(“目录”).Range(“b:iv”).EntireColumn.ColumnWidth = 20End Sub建立工作表文本目录Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)Sheets(1).Name = “目录”For i = 2 To Sheets.CountCells(i – 1, 1) = Sheets(i).Name‘Sheets(1).Hyperlinks.Add Cells(i –1, 1), “#” & Sheets(i).Name & “!A1″ ‘添加超链接NextEnd Sub查另一文件的全部表名Sub 查另一文件的全部表名()On Error Resume NextDim i%Dim sh As WorksheetApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=ThisWorkbook.Path & “\2.xls”Windows(“1.xls“).Activate‘当前文件名称Sheets(“Sheet1“).Select ‘当前表名称i = 1 ’将表名称返回到第1行For Each sh In Workbooks(“2.xls”).WorksheetsCells(i, 1) = ‘将表名称返回到第1列i = i + 1 ‘返回每个表名称向下移动1行Next shWindows(“2.xls”).Close ‘关闭对象文件Application.ScreenUpdating = TrueEnd 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 IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext nEnd Sub为指定工作表加指定密码保护表Sub 为指定工作表加指定密码保护表()Sheet10.Protect Password:=”123″End Sub在有密码的工作表执行代码Sub 在有密码的工作表执行代码()Sheets(“1″).Unprotect Password:=123 ‘假定表名为“1”，密码为“123” 打开工作表Range(“C:C”).SpecialCells(xlCellTypeBlanks).EntireRow.Hid den = True ‘隐藏C列空值行Sheets(“1″).Protect Password:=123 ‘重新用密码保护工作表End Sub执行前需要验证密码的宏(控件按钮代码)Private Sub CommandButton1_Click()If InputBox(“请输入密码：”) <> “123″ Then ‘密码是123 MsgBox “密码错误,按确定退出!”, 64, “提示”Exit SubEnd IfCells(1, 1) = 10End SubSub 执行前需要验证密码的宏()If InputBox(“请输入您的使用权限:”, “系统提示”) = 123 Then重排窗口‘要执行的宏代码或宏名称ElseMsgBox “对不起,您没有使用该宏的权限,按确定键后退出!”End IfEnd Sub拷贝A1公式和格式到A2Sub 拷贝A1公式到A2()Workbooks(“临时表”).Sheets(“表1″).Range(“A1″).CopyWorkbooks(“临时表”).Sheets(“表2″).Range(“A2″).PasteSpecialEnd Sub复制单元数值Sub 复制数值()s = Workbooks(“book1″).Sheets(“Sheet1″).Range(“A1:A2″) Workbooks(“book2″).Sheets(“Sheet1″).Range(“A1:A2″) = s End Sub插入数值条件格式Sub 插入数值条件格式()Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:=”70″Selection.FormatConditions(1).Interior.ColorIndex = 45Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _Formula1:=”55″Selection.FormatConditions(2).Interior.ColorIndex = 39Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:=”60″Selection.FormatConditions(3).Interior.ColorIndex = 34 End Sub插入透明批注Sub 插入透明批注()Selection.AddCommentment.Visible = FalseDim XS As WorksheetFor i = 1 To ments.Countments(i).Text “透明批注”ments(i).Shape.Fill.Visible = msoFalse NextEnd Sub添加文本Sub 添加文本()Selection = Selection + “×”‘不可在数字后添加文本‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End Sub光标定位到指定工作表A列最后数据行下一单元Sub 光标定位到指定工作表A列最后数据行下一单元()a = Sheets(“数据库”).[a65536].End(xlUp).RowSheets(“数据库”).SelectRange(“A” & a + 1).SelectEnd Sub定位选定单元格式相同的全部单元格Sub 定位选定单元格式相同的全部单元格()Dim FirstCell As Range, FoundCell As RangeDim AllCells As RangeWith 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.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.FormulaHiddenEnd WithSet FirstCell = edRange.Find(what:=”", searchformat:=True)If FirstCell Is Nothing ThenExit SubEnd IfSet AllCells = FirstCellSet FoundCell = FirstCellDoSet FoundCell =edRange.Find(After:=FoundCell, what:=”", searchformat:=True)If FoundCell Is Nothing Then Exit DoSet AllCells = Union(FoundCell, AllCells)If FoundCell.Address = FirstCell.Address Then Exit DoLoopAllCells.SelectEnd Sub按当前单元文本定位Sub 按当前单元文本定位()ABC = SelectionDim aa As RangeFor Each a In edRange If a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub按固定文本定位Sub 文本定位()Dim aa As RangeFor Each a In edRange If a Like “*合计*” ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub删除包含固定文本单元的行或列Sub 删除包含固定文本单元的行或列()DoCells.Find(what:=”哈哈”).ActivateSelection.EntireRow.Delete ‘删除行‘ Selection.EntireColumn.Delete ‘删除列Loop Until Cells.Find(what:=”哈哈”) Is Nothi ng End Sub定位数据及区域以上的空值Sub 定位数据及区域以上的空值()Dim aa As RangeFor Each a In edRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub右侧单元自动加5(工作表代码)Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd Sub当前单元加2Sub 当前单元加2()Selection = Selection + 2‘Selection = Workbooks(“临时表”).Sheets(“表2″).Range(“A1″) 调用指定地址内容End SubA列等于A列减B列Sub A列等于A列减B列()For i = 1 To 23Cells(i, 1) = Cells(i, 1) – Cells(i, 2)NextEnd Sub用于光标选定多区域跳转指定单元(工作表代码)Private Sub Worksheet_SelectionChange(ByVal T As Range) a = Array([b6:b7], [e6], [h6])For i = 0 To 2If Not Application.Intersect(T, a(i)) Is Nothing Then[a1].Select: Exit ForEnd IfNextEnd Sub将A1单元录入的数据累加到B1单元（工作表代码）Private Sub Worksheet_Change(ByVal Target As Range)Dim t As LongIf Target.Address = “$A$1″ Thent = Sheet1.Range(“$B$1″).ValueSheet1.Range(“$B$1″).Value = t + Target.ValueEnd IfEnd Sub在指定颜色区域选择单元时添加/取消”√”（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> “√”, “√”, “”)NextEnd Sub在指定区域选择单元时添加/取消”√”（工作表代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target,Range(“D6:D20″)) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = “” Then.Value = “√”Else.Value = “”End IfEnd WithNextEnd IfEnd IfEnd Sub双击指定单元，循环录入文本（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)If T.Address <> “$A$1” Then Exit SubCancel = TrueT = IIf(T = “好”, “中”, IIf(T = “中”, “差”, “好”)) End Sub。
EXCEL宏代码大全
EXCEL宏代码大全本文件部分文章来源于网络000. 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))001. A列等于A列减B列Sub A列等于A列减B列() For i = 1 To 23 Cells(i, 1) = Cells(i, 1) - Cells(i, 2) Next End Sub002. B列录入数据时在A列返回记录时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then Target.Offset(, -1) = Now End If End Sub003. Excel宏常用代码本大类暂没有内容，以下是关于本类的所有记录集。
004. Sub 以当前日期为名称另存文件()ActiveWorkbook.SaveAs Filename:=Date & ".xls" End Sub005. Sub 启用保存()mandBars("File").Controls(4).Enabled = True mandBars("File").Controls(5).Enabled = True End Sub006. Sub 执行前需要验证密码的宏()If InputBox("请输入您的使用权限:", "系统提示") = 123 Then 重排窗口 ''要执行的宏代码或宏名称 Else MsgBox "对不起,您没有使用该宏的权限,按确定键后退出!" End If End Sub007. Sub 选择第5行开始所有数据行B()Rows("5:" & Cells.Find("*", , , , 1, 2).Row).Select End Sub008. VBA返回公式结果Sub VBA返回公式结果() x = Application.WorksheetFunction.Sum(Range("a2:a100"))Range("B1") = x End Sub009. 不连续区域录入对勾Sub 批量录入对勾() Selection.FormulaR1C1 = "√" End Sub010. 不连续区域录入当前单元地址Sub 区域录入当前单元地址() For Each mycell In Selection mycell.FormulaR1C1 = mycell.Address Next End Sub011. 不连续区域录入当前数字日期Sub 区域录入当前数字日期() Selection.FormulaR1C1 = Format(Now(), "yyyymmdd") End Sub012. 不连续区域录入当前文件名Sub 批量录入当前文件名() Selection.FormulaR1C1 = End Sub013. 不连续区域录入当前日期Sub 区域录入当前日期() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d") End Sub014. 不连续区域录入当前日期和时间Sub 区域录入当前日期和时间() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss") End Sub015. 不连续区域插入当前文件名和表名及地址Sub 批量插入当前文件名和表名及地址() For Each mycell In Selection mycell.FormulaR1C1 = "[" + + "]" + + "!" + mycell.Address Next End Sub016. 不连续区域插入文本Sub 批量插入文本() Dim s As Range For Each s In Selection s = "文本内容" & s Next End Sub017. 不连续区域添加文本Sub 批量添加文本() Dim s As Range For Each s In Selection s = s & "文本内容" Next End Sub018. 为当前选定的多单元插入指定名称Sub 为当前选定的多单元插入指定名称() = "临时" s.Add Name:="临时", RefersT o:=Selection ''或者换用这行代码也可以 End Sub019. 为指定工作表加指定密码保护表Sub 为指定工作表加指定密码保护表() Sheet10.Protect Password:="123" End Sub020. 为指定工作表设置滚动范围（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Sheet1.ScrollArea = "A1:M30" EndSub021. 从指定位置向下同时录入多单元指定内容Sub 从指定位置向下同时录入多单元指定内容() Dim arr arr = Array("1", "2", "13", "25", "46", "12", "0", "20") [B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr) End Sub022. 以A1单元内容批量插入批注Sub 以A1单元内容批量插入批注() Dim r As Range If Selection.Cells.Count > 0 Then For Each r In Selection r.AddComment ment.Visible = False ment.Text Text:=[a1].T ext Next End If End Sub023. 以A1单元文本作表名插入工作表Sub 以A1单元文本作表名插入工作表() Dim nm As String nm = [a1] Sheets.Add = nm End Sub024. 以当前日期为新文件名另存文件Sub 以当前日期为新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls" End Sub025. 以当前日期和时间为新文件名另存文件Sub 以当前日期和时间为新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls" End Sub026. 以指定区域为表目录补充新表Sub 以指定区域为表目录补充新表() Dim dic As Object, sh AsWorksheet Dim arr, item arr = Range("B1:BB1") Set dic = CreateObject("scripting.dictionary") For Each sh In ThisWorkbook.Worksheets dic.Add ,027. 以指定单元内容为新文件名另存文件Sub 以指定单元内容为新文件名另存文件() ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.[A1] End Sub028. 以本工作表名称另存文件到当前目录Sub 以本工作表名称另存文件到当前目录() ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & & ".xls" End Sub029. 以活动工作表名称另存文件到Excel当前默认目录Sub 以活动工作表名称另存文件到Excel当前默认目录() ActiveWorkbook.SaveAs Filename:= & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=030. 使单元内容保持不变的工作表代码Private Sub Worksheet_Change(ByVal Target As Range) [B2] = "不可更改的数据" End Sub031. 保存并退出ExcelSub 保存并退出Excel() Application.SendKeys ("{ENTER}{ENTER}%fx") ActiveWorkbook.Save End Sub032. 保护工作表时取消选定锁定单元Sub 取消选定锁定单元() ActiveSheet.EnableSelection =xlUnlockedCells ''用于2000版 End Sub033. 光标定位到名称指定位置Sub 定位() Application.Goto Range(Evaluate("名称")) End Sub034. 光标定位到指定工作表A列最后数据行下一单元Sub 光标定位到指定工作表A列最后数据行下一单元() a = Sheets("数据库").[a65536].End(xlUp).Row Sheets("数据库").Select Range("A" & a + 1).Select End Sub035. 光标所在行上移一行Sub 光标所在行上移一行() Dim i% i = Split(ActiveCell.Address, "$")(2) If i > 1 Then Rows(i).Cut Rows(i - 1).Insert Shift:=xlDown End If End Sub036. 光标移动Sub 光标移动() ActiveCell.Offset(1, 2).Select ''向下移动1行，向右移动2列 End Sub037. 全选固定范围内小于0的单元Sub 全选固定范围内小于0的单元() Dim rng As Range Dim yvhf For Each rng In Range("d6: i18") If rng < 0 Then yvhf = yvhf & rng.Address & "," End If Next Range(Left(yvhf, Len(yvhf) - 1)).Select End Sub038. 全选选定范围内小于0的单元Sub 全选选定范围内小于0的单元() Dim rng As Range Dim yvhf For Each rng In Selection If rng < 0 Then yvhf = yvhf & rng.Address & "," End If Next Range(Left(yvhf, Len(yvhf) - 1)).Select End Sub039. 全部显示指定表的自动筛选Sub 全部显示指定表的自动筛选() If Sheet1.FilterMode = True Then Sheet1.ShowAllData End If End Sub040. 全部清除当前选择区域Sub 全部清除当前选择区域() Selection.Clear '' Range("A1:B10").Clear ''全部清除指定区域 End Sub041. 关闭文件时执行指定宏(工作簿代码)Private Sub Workbook_BeforeClose(Cancel As Boolean) 重排窗口 ''要执行的宏名称 End Sub042. 关闭文件时自动隐藏指定工作表(ThisWorkbook)Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Unprotect Sheets("Sheet2").Visible = False Sheets("Sheet3").Visible = False ActiveWorkbook.Protect Structure:=True, Windows:=Fal043. 分离临时表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.T extToDisplay =044. 分离临时表A列数据的文本和超链接并整理到数据库表Sub 分离A列中的超链接到指定表的B和C列() i = Worksheets("数据库").Range("b60000").End(xlUp).Row For Each h In Worksheets("临时").Hyperlinks Worksheets("数据库").Cells(i + 1, 2)= h.TextT oDisplay Worksheets("数据库").Cells(045. 删除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 Sub046. 删除A列空行Sub 删除A列空行() Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub047. 删除A列非数字单元行Sub 删除A列非数字单元行() i = [a65536].End(xlUp).Row Range("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End Sub048. 删除B列数据的超链接Sub 删除超链接() For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)Sheet1.Range(Rng.Address).Hyperlinks.Delete Next End Sub049. 删除全部名称Sub 删除全部名称() On Error Resume Next Dim l As Integer l = s.Count For i = l T o 1 Step -1 s(i).Delete Next End Sub050. 删除全部未选定工作表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.Selec051. 删除包含固定文本单元的行或列Sub 删除包含固定文本单元的行或列() Do Cells.Find(what:="哈哈").Activate Selection.EntireRow.Delete ''删除行 '' Selection.EntireColumn.Delete ''删除列 Loop Until Cells.Find(what:="哈哈") Is Nothing End Sub052. 删除指定文件Sub 删除指定文件() Kill "E:\信件\1.xls" End Sub053. 删除指定行Sub 删除指定行() Workbooks("临时表").Sheets("表2").Range("5:5").Delete End Sub054. 判断指定文件是否已经打开Sub 判断指定文件是否已经打开() Dim x As Integer For x = 1 To Workbooks.Count If Workbooks(x).Name = "函数.xls" Then ''文件名称 MsgBox "文件已打开" Exit Sub End If Next MsgBox "文件未打开" End Sub055. 加数据有效限制Sub 加数据有效限制() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="******************".IgnoreBlank = False .InCellDropd056. 单元区域引用（工作表代码）Private Sub Worksheet_Activate()Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").Value End Sub057. 单元反选Sub 单元反选() Application.DisplayAlerts = False Application.ScreenUpdating = False Dim raddress As String, taddress As String raddress = Selection.Address taddress = edRange.Address058. 单元格录入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 "~"059. 单元格录入数据时运行宏的代码Private Sub Worksheet_Change(ByVal Target As Range) 重排窗口 End Sub060. 去除指定范围内的对象Sub 去除指定范围内的对象() ??Dim p As Shape Set My = Worksheets("工作表名") For Each p In My.Shapes If Not Application.Intersect(p.T opLeftCell, Range("范围")) Is Nothing Then p.Delete Next061. 双击单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Range("$A$1") = "关闭" Then Exit Sub Select Case T arget.Address Case "$A$4" Call 宏1 Cancel = True Case "$B$4"062. 双击单元隐藏该行（工作表代码）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Rows(Target.Row).Hidden = True End Sub063. 双击指定区域单元执行宏(工作表代码)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 Then064. 双击指定单元，循环录入文本（工作表代码）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) T arget.Offse065. 反方向文本(自定义函数)Function zhyz(zhyz1 As Range) zhyz = StrReverse(zhyz1) End Function 将代码复制到模块后单元公式：=zhyz(单元格)066. 取消指定行或列的隐藏Sub 取消隐藏行() Rows("3:5").Select Selection.EntireRow.Hidden = False End Sub Sub 取消隐藏列() Columns("C:F").Select Selection.EntireColumn.Hidden = False End Sub067. 取消数据有效限制Sub 取消数据有效限制() WithSelection.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = False .InCellDropdown = False .InputTitle =068. 取消自动筛选()Sub 取消自动筛选() ActiveSheet.AutoFilterMode = False End Sub069. 取消选定区域的公式只保留值(假空转真空)Sub 取消选定区域的公式只保留值() ?''?? Sheets("数据归并集中").Select ''指定工作表 ?''?? Columns("Q:R").Select ''指定范围 Selection.Value = Selection.Value End Sub070. 另存所有工作表为工作簿Sub 另存所有工作表为工作簿() Dim sht As Worksheet Application.ScreenUpdating = False ipath = ThisWorkbook.Path & "\" For Each sht In Sheets sht.Copy ActiveWorkbook.SaveAs ipath & & ".xls" ''(工作表名071. 另存指定文件名Sub 另存指定文件名() ActiveWorkbook.SaveAs ThisWorkbook.Path & "\别名.xls" End Sub072. 另存本表为TXT文件Sub 另存本表为TXT文件() Dim s As String Dim FullName As String, rng As Range Application.ScreenUpdating = False FullName = ( & ".txt") ''以当前表名为TXT文件名 '' FullName = Replace(ThisWorkboo073. 右侧单元自动加5(工作表代码)Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target.Offset(0, 1) = T arget + 5 Application.EnableEvents = True End Sub074. 合并A1至C1的内容写到D15单元的批注中‘/dispbbs.asp?boardid=2&id=251887 northwolves版主 Sub 将A1至C1的内容写到D15单元的批注中() [iv1:iv12] = "=rc1 & "" ""& rc2 &"" ""& rc3" [d15].AddComment Join(Application.Transpose([iv1:i075. 合并各工作表内容Sub 合并各工作表内容() sp = InputBox("各表内容之间，间隔几行？不输则默认为0") If sp = "" Then sp = 0 End If st = InputBox("各表从第几行开始合并？不输则默认为2") If st = "" Then st = 2 End If Sheets(1).Select Sheets.Add If st076. 合并指定目录中所有文件中相同格式工作表的数据Sub 合并数据() ''合并指定目录中所有文件中相同格式工作表的数据 ''见/dispbbs.asp?boardid=1&replyid=900613&id=249319&page=1 &skin=0&Star=2帖11楼eq800的代码 Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i077. 回车光标向下Sub 录入光标向下() Application.MoveAfterReturnDirection = xlDown End Sub078. 回车光标向右Sub 录入光标向右() Application.MoveAfterReturnDirection =xlToRight End Sub079. 固定区域单元分类变色Sub 单元分类变色() Dim rng As Range For Each rng In Range("d6: i18") If rng < 0 Then rng.Interior.ColorIndex = 4 ''小于0的单元变绿底色 End If Next For Each rng In Range("d6: i18") If rng > 0 Then rng.080. 在A1返回当前选中单元格数量Sub 在A1返回当前选中单元格数量() [A1] = Selection.Count End Sub081. 在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 =082. 在A和B列返回当前选区的名称和公式Sub 在A和B列返回当前选区的名称和公式() [a1].ListNames End Sub083. 在F1单元显示光标位置批注内容的代码Private Sub Worksheet_SelectionChange(ByVal Target As Range) a = Selection.Address b = Range(a).NoteText Cells(1, 6) = b End Sub084. 在M和N列的14行以下选择单元时显示调用日历控件（工作表代码）Private Sub Calendar1_Click() With Calendar1 ActiveCell= .Value .Visible = False End With End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 13 And Target085. 在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）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 S086. 在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Private Sub CommandButton1_Click() With CommandButton1 If .Caption = "保护工作表" Then Call 保护工作表 .Caption = "取消工作表保护" Exit Sub End If If .Caption = "取消工作表保护" Then Call 取消工作表保护 .Caption = "保护工作表"087. 在多个宏中依次循环执行一个（控件按钮代码）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 Sub088. 在当前工作组各表中分别执行指定宏''northwolves版主解答 /dispbbs.asp?boardid=2&id=251426&star=2#914934 Sub 在当前工作组各表中分别执行指定宏() Dim SH As Worksheet For Each SH In ActiveWindow.SelectedSheets SH.Activate 临时 N089. 在当前选区有条件替换数值为文本Sub 在当前选区有条件替换数值为文本() For Each r In Selection If r.Value > 18 And r.Value < 29.5 Then r.Value = "Y" Next End Sub090. 在所有工作表的A1单元返回顺序号Sub 在所有工作表的A1单元返回顺序号() For i = 1 T o Sheets.Count Sheets(i).Cells(1, 1) = "''" & Application.WorksheetFunction.Text(0 + i, "000") Next End Sub091. 在指定区域选择单元时数值加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 Sub092. 在指定单元记录打印和预览次数（工作簿代码）Private Sub Workbook_BeforePrint(Cancel As Boolean) Range("A1") = 1 + Range("A1") End Sub093. 在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Worksheets("表2").Range("A1") = Target.Address(0, 0) End Sub094. 在有密码的工作表执行代码Sub 在有密码的工作表执行代码() Sheets("1").Unprotect Password:=123 ''假定表名为“1”，密码为“123”打开工作表 Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True ''隐藏C列空值行 Sheets("1").Protect Password:=123095. 在目录表建立本工作簿中各表链接目录Sub 在目录表建立本工作簿中各表链接目录() Dim s%, Rng As Range On Error Resume Next Sheets("目录").Activate If Err = 0 Then Sheets("目录").UsedRange.Delete Else Sheets.Add = "目录" End If For i =096. 在第一个表前插入多工作表Sub 在第一个表前插入多工作表() Sheets(1).Select For I = 1 To 50 = "新表" & I Next End Sub097. 填公式Sub 填公式() Range("C2:C12").Value = "=SUM(A2:B2)" End Sub098. 处理导入的显示为科学计数法样式的身份证号Sub 处理导入的显示为科学计数法样式的身份证号() Selection.Value = Selection.Formula End Sub099. 复制单元数值Sub 复制数值() s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2") Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = s End Sub100. 复制单元格所在列Sub 复制单元格所在列() Selection.EntireColumn.Copy End Sub101. 复制单元格所在行Sub 复制单元格所在行() Selection.EntireRow.Copy End Sub102. 复制当前工作簿的报表到临时工作簿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 Workbook103. 奇偶页分别打印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 "现在打印偶数页,按确定开始." For104. 定义指定工作表标签颜色Sub 定义指定工作表标签颜色() Sheets("Sheet1").T ab.ColorIndex = 46 End Sub105. 定位数据及区域以上的空值Sub 定位数据及区域以上的空值() Dim aa As Range For Each a In edRange If a Like〈0 Then If aa Is Nothing Then Set aa = a.Cells Else Set aa = Union(aa, a.Cells) End If End If Next aa.Select106. 定位选定单元格式相同的全部单元格Sub 定位选定单元格式相同的全部单元格() Dim FirstCell As Range, FoundCell As Range Dim AllCells As Range With Application.FindFormat .Clear .NumberFormatLocal = Selection.NumberFormatLocal .HorizontalAlignment =107. 实现删去特定的行Sub test() For Each i In ThisWorkbook.Worksheets(1).range("E:E") If i.Value = "32766" Then Rows(i.Row).Delete End If Next i End Sub ''用的是第一张工作表，可以按需要改Worksheets(1)为指定的工作表。
经典Excel VBA代码
经典Excel VBA代码1VBA基础在大家的关注声中即将告一段落了，有许多经典的VBA操作我们只是作了简要的介绍，想要熟练地使用VBA还需要大家慢慢地去消化和吸收，然后在实践中总结和提高。
最后我们收集了常见的VBA代码以飨广大的读者，希望对大家有所启示。
Application（Excel程序）篇Application.EnableEvents= True/ False ’启用/禁用所有事件Application.DisplayAlerts=True/False ’显示/关闭警告框提示框Appli cation.ScreenUpdating= True/False ’显示/关闭屏幕刷新Application.StatusBar = "软件报专用" ’在地址栏中显示文本，标题栏用Caption属性Application.Cursor = xlIBeam ‘设置光标形状为Ⅰ字形，xlWait为沙漏(等待)形，xlNormal为正常Application.WindowState = xlMinimized ‘窗口最小化，xlMaximized最大化，xlNormal为正常Application.Ac tivateMicrosoftApp xlMicrosoftWord ’开启Word应用程序Application.TemplatesPath ‘获取工作簿模板的位置Application.CalculateFull ’重新计算所有打开的工作簿中的数据Application.RecentFiles.Maximum = 2 ’将最近使用的文档列表数设为2Application.RecentFiles(3).Open ’打开最近打开的文档中的第3个文档Application.AutoCorrect.AddReplacement "sweek", "软件报" ’自动将输入的"sweek"更正为"软件报"Application.Dialogs(xlDialogPrint).Show ‘显示打印文档的对话框Application.OnTime Now + TimeValue("00:00:45"), "process" ’45分钟后执行指定过程Application.OnTime TimeValue("14:00:00"), " process " ’下午2点执行指定过程Application.OnTime EarliestTime:=TimeValue("14:00:00"), _Procedure:="process", Schedule:=False ’取消指定时间的过程的执行工作簿/工作表篇ActiveWorkbook.Sheets.Count ’获取活动工作薄中工作表数ActiveWorkbook.LinkSources(xlExcelLinks)(1) ‘返回当前工作簿中的第一条链接ThisWorkbook.Worksheets(“sheet2”).Visible=xlSheetHidden ‘隐藏工作表，与在Excel菜单中执行“格式—工作表—隐藏”操作一样ThisWorkbook.Worksheets(“sheet2”).Visible=xlSheetVeryHidden ‘隐藏工作表，不能通过在Excel 菜单中执行“格式—工作表—取消隐藏”来重新显示工作表ThisWorkbook.Worksheets(“sheet2”).Visible=xlSheetVisible ‘显示被隐藏的工作表ThisWorkbook.Sheets(1).ProtectContents ‘检查工作表是否受到保护ActiveSheet.Columns("B").CutActiveSheet.Columns("F").Insert ‘以上两句将B列数据移至F列，原C列后的数据左移ActiveSheet.Range(“A:A”).EntireColumn.AutoFit ‘自动调整当前工作表A列的列宽ActiveSheet.Cells.SpecialCells(xlCellTypeConstants,xlTextValues) ‘选中当前工作表中常量和文本单元格ActiveSheet.Cells.SpecialCells(xlCellTypeConstants,xlErrors+xlTextValues) ‘选中当前工作表中常量和文本及错误值单元格edRange.Rows.Count ‘当前工作表中已使用的行数ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(3), , 2 ‘在第3张工作表之前添加2个新的工作表ActiveSheet.Move After:=ActiveWorkbook. _She ets(ActiveWorkbook.Sheets.Count) ’将当前工作表移至工作表的最后Worksheets(Array(“sheet1”,”sheet2”)).Select ’同时选择工作表sheet1和sheet2 edRange.FormatConditions.Delete ‘删除当前工作表中应用的条件格式Cells.Hyperlinks.Delete ‘取消当前工作表中所有单元格的超链接ActiveSheet.PageSetup.RightFooter=A ctiveWorkbook.FullName ‘在页脚显示文件的路径ActiveSheet.PrintPreview Enablechanges:=False ‘禁用显示在Excel的“打印预览”窗口中的“设置”和“页边距”按钮单元格/单元格区域篇edRange.Row ‘获取已使用的单元格区域的第一行的行号Range(“A65536”).End(xlUp).Row ‘返回A列最后一行(即记录的总条数)cell.Range(“A1”).HasFormula ‘检查单元格或单元格区域中的第一个单元格是否含有公式或cell.HasFormula ‘工作表中单元格是否含有公式Target.EntireColumn.Select ‘选择单元格所在的整个列，Target.EntireRow.Select为选择单元格所在的整行ActiveCell.Row ‘活动单元格所在的行号，ActiveCell.Column为活动单元格所在的列数ActiveWindow.ScrollRow = 2 ’将当前工作表窗口滚动到第2行ActiveWindow.ScrollColumn = 5 ’将当前工作表窗口滚动到第5列Worksheets("sheet1").Range("A1:C5").CopyPicture xlScreen, xlBitmap ’将指定的单元格区域的内容复制成屏幕快照Selection.Hyperlinks.Delete ‘删除所选区域的所有链接ActiveSheet.Cells(1, 1).Font.Bold = TRUE ‘Bold属性用于设置字体是否为加粗， Size属性设置字体大小， ColorIndex属性设置字体颜色（其值为颜色索引号）， Italic属性设置字型是否为倾斜， Name 属性设置字体名称ActiveSheet.Cells(1, 1).Interior.ColorIndex = 3 ‘将单元格的背景色设置为红色IsEmpty (ActiveCell.Value) ’判断活动单元格中是否有值ActiveCell.Value = UCase(ActiveCell.Value) ’将当前单元格中的字符转换成大写ActiveCell.Value = StrConv(ActiveCell.Value, vbLowerCase) ’将活动单元格中的字符串转换成小写ActiveCell.CurrentRegion.Select ’选择当前活动单元格所在的连续的非空区域，也可以用Range(ActiveCell, UsedRange.End(xlDown)).SelectActiveCell.Offset(1,0).Select ’活动单元格下移一行Range(“B2”).Offset(ColumnOffset:=1)或Range(“B2”).Offset(,1) ‘读取指定单元格右侧单元格中的数据Range(“B2”).Offset(Rowo ffset:=-1)或Range(“B2”).Offset(-1) ‘读取指定单元格上一行单元格中的数据Range(“A1”).Copy Range(“B1”) ’复制单元格A1中的内容到B1中Range(“A1:D8”).Copy Range(“H1”) ’将指定单元格区域复制到从H1开始的区域中，用Cut方法可以实现剪切操作ActiveWindow.RangeSelection.Value = "软件报" ’将指定字符串输入到所选单元格区域中窗体（控件）篇Option Explicit ’强制对模块内所有变量进行声明Userform1.Show ‘显示用户窗体Load Userform1 ‘加载一个用户窗体,但该窗体处于隐藏状态Userform1.Hide ‘隐藏用户窗体Unload Userform1 或Unload Me ‘卸载用户窗体Me.Height=Int(0.5 * ActiveWindow.Height) ‘窗体高度为当前活动窗口高度的一半，宽度用ActiveWindow. Width属性boBox1.AddItem Sheets("Shee t1").Cells(1, 1) ‘将指定单元格中的数据添加到复合框中ListBox1.List=MyProduct() ‘将数组MyProduct的值添加到列表框ListBox1中ListBox1.RowSource=”Sheet1!isum” ‘将工作表Sheet1中名为的isum区域的值添加到列表框中ListBox1.Selected(0) ‘选中列表框中的指定的条目ListBox1.RemoveItem ListBox1.ListIndex ‘移除列表框中选中的条目If MsgBox(“要退出吗？”,vbYesNo)<>vbYes Then Exit Sub ’返回值不为“是”，则退出Config=vbYesNo+vbQuestion+vbDefaultButton2 ’使用常量的组合，赋值组Config变量，并设置第二个按钮为缺省按钮MsgBox “This is the first line.” & vbNewLine & “Second line.” ’在消息框中强制换行，也可用vbCrLf代替vbNewLine。
Excel屏蔽代码大全
Application.OnKey "^h", " " '屏蔽组合键Ctrl+H，替换
……
End Sub
mandBars(1).Controls("工具(&T)").Controls("宏(&M)").Enabled = False '工具-宏变成灰色，如忘了变回来，工具-自定义-工具栏选项-工作表菜单栏-重新设置即可
mandBars("ply").Controls("查看代码(&V)").Enabled = False '右键工作表标签“查看代码”为灰色
Application.OnKey "%{f8}", " " '屏蔽组合键ALT+F8
Application.OnKey "%{f8}" '解除屏蔽ALT+F8
mandBars(1).Controls("工具(&T)").Controls("选项(&O)...").Visible = False '去除工具-选项
mandBars(1).Controls("工具(&T)").Controls("选项(&O)...").Enabled = False '工具-选项变灰色
mandBars("Forms").Visible = False '屏蔽窗体
(完整)excel常用代码集合(非常重要)
批量将工作表转换为独立工作簿Sub Newbooks（)'EH技术论坛.VBA编程学习与实践。
看见星光Dim sht As Worksheet, strPath＄With Application.FileDialog（msoFileDialogFolderPicker)’选择保存工作薄的文件路径If 。
Show ThenstrPath = 。
SelectedItems(1)’读取选择的文件路径ElseExit Sub'如果没有选择保存路径，则退出程序End IfEnd WithIf Right（strPath, 1) <〉”\” Then strPath = strPath ＆"\"Application。
DisplayAlerts = False'取消显示系统警告和消息，避免重名工作簿无法保存.当有重名工作簿时，会直接覆盖保存。
Application。
ScreenUpdating = False’取消屏幕刷新For Each sht In Worksheets’遍历工作表sht.Copy'复制工作表,工作表单纯复制后，会成为活动工作薄With ActiveWorkbook。
SaveAs strPath ＆sht。
Name, xlWorkbookDefault'保存活动工作薄到指定路径下,以默认文件格式。
Close True ’关闭工作薄并保存End WithNextApplication。
ScreenUpdating = True ’恢复屏幕刷新Application。
DisplayAlerts = True ’恢复显示系统警告和消息MsgBox ”处理完成。
”, ，"提醒"End Sub一键将总表数据拆分为多个分表Sub NewShts（)Dim d As Object, sht As Worksheet， arr, brr, r, kr, i&, j&， k&， x＆Dim Rng As Range, Rg As Range, tRow&， tCol＆， aCol＆, pd＆Application.ScreenUpdating = False ’关闭屏幕更新Application。
EXCELVBA20个有用的ExcelVBA代码
EXCELVBA20个有用的ExcelVBA代码1.显示多个隐藏的工作表如果你的工作簿里面有多个隐藏的工作表，你需要花很多时间一个一个的显示隐藏的工作表。
下面的代码，可以让你一次显示所有的工作表Sub UnhideAllWoksheets()Dim ws As WorksheetFor Each ws In ActiveWorkbook.Worksheetsws.Visible = xlSheetVisibleNext wsEnd Sub2.隐藏除了活动工作表外的所有工作表如果你做的报表，希望隐藏除了报表工作表以外的所有工作表，则可以用一下代码来实现：Sub HideAllExcetActiveSheet()Dim ws As WorksheetFor Each ws In ThisWorkbook.WorksheetsIf <> Thenws.Visible = xlSheetHiddenEnd ifNext wsEnd Sub3.用VBA代码按字母的顺序对工作表进行排序如果你有一个包含多个工作表的工作簿，并且希望按字母对工作表进行排序，那么下面的代码，可以派上用场。
Sub SortSheetsTabName()Application.ScreenUpdating = FalseDim ShCount As Integer, i As Integer, j As IntegerShCount = Sheets.CountFor i = 1 To ShCount - 1For j = i + 1 To ShCountIf Sheets(j).Name < Sheets(i).Name ThenSheets(j).Move before:=Sheets(i)End IfNext jNext iApplication.ScreenUpdating = TrueEnd Sub4.一次性保护所有的工作表如果工作薄里面有多个工作表，并且希望保护所有的工作表，那么下面的代码，可以派上用场。
用VBA隐藏Excel2003菜单栏和工具栏
用VBA隐藏Excel2003菜单栏和工具栏在Excel 2003中，有时需要限制用户的操作，例如当用户打开某个指定的工作簿时，Excel 2003菜单栏和工具栏被隐藏起来。
而当关闭该工作簿重新打开其他工作簿后，菜单栏和工具栏又恢复正常。
用VBA代码可以实现这个目的，步骤如下：1.打开需要屏蔽菜单栏和工具栏的工作簿，按Alt+F11，打开VBA编辑器。
2.在“工程”窗口（视图－工程管理器）中选择“ThisWorkBook”，在右侧的代码窗口中输入下面的代码：Private Sub Workbook_BeforeClose(Cancel As Boolean)showhide (bHide = True)End SubPrivate Sub Workbook_Open()showhide (bHide = False)End SubSub showhide(Optional bHide As Boolean)Dim cmb As CommandBarStatic col As New CollectionIf bHide ThenFor Each cmb In mandBarsIf cmb.Type = msoBarTypeMenuBar Or cmb.Type = msoBarTypeNormal ThenIf cmb.Visible Thencmb.Enabled = FalseIf cmb.Visible Then cmb.Visible = Falsecol.Add cmb, End IfEnd IfNext cmbElseIf col Is Nothing Or col.Count = 0 ThenFor Each cmb In mandBarsIf cmb.Type = msoBarTypeMenuBar Or cmb.Type = msoBarTypeNormal ThenIf Not cmb.Visible Or Not cmb.Enabled Thencmb.Enabled = TrueIf (Not cmb.Visible) And cmb.Enabled Then cmb.Visible = TrueEnd IfEnd IfNext cmbElseFor Each cmb In colIf Not cmb.Visible Or Not cmb.Enabled Thencmb.Enabled = TrueIf (Not cmb.Visible) And cmb.Enabled Then cmb.Visible = TrueEnd IfNext cmbEnd IfSet col = NothingEnd IfEnd Sub3.在退出该工作簿前，先要让菜单栏和工具栏隐藏起来，方法是：鼠标在代码Private Sub Workbook_Open()showhide (bHide = False)End Sub中间单击一下，让光标停留在这段代码中间，然后按F5键运行该段代码，这时Excel中的菜单栏和工具栏都将被隐藏。
EXCEL工作表保护破解代码
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND2, _
"$$", PWord1), vbInformation, HEADER
'leverage finding Pword by trying on other sheets
For Each w2 In Worksheets
Application.ScreenUpdating = False
With ActiveWorkbook
WinTag = .ProtectStructure Or .ProtectWindows
End With
ShTag = False
For Each w1 In Worksheets
Loop Until True
On Error GoTo 0
End If
If WinTag And Not ShTag Then
MsgBox MSGONLYONE, vbInformation, HEADER
Exit Sub
End If
On Error Resume Next
For Each w1 In Worksheets
办公软件学习技巧：Excel VBA常用代码100句
Excel VBA常用代码100句(1) Option Explicit 强制对模块内全部变量进行声明(2) Option Base 1 指定数组的第一个下标为1(3) On Error Resume Next 忽视错误连续执行VBA代码,避开消失错误消息(4) On Error GoTo 100 当错误发生时跳转到过程中的某个位置(5) On Error GoTo 0 恢复正常的错误提示(6) Application.DisplayAlerts=False 在程序执行过程中使消失的警告框不显示(7) Application.DisplayAlerts=True 在程序执行过程中恢复显示警告框(8) Application.ScreenUpdating=False 关闭屏幕刷新(9) Application.ScreenUpdating = True 打开屏幕刷新(10) Workbooks.Add() 创建一个新的工作簿(11) Workbooks(“book1.xls”).Activate 激活名为book1的工作簿(12) ThisWorkbook.Save 保存工作簿(13) ThisWorkbook.close 关闭当前工作簿(14) ActiveWorkbook.Sheets.Count 猎取活动工作薄中工作表数(15) 返回活动工作薄的名称(16) ‘返回当前工作簿名称(17) ThisWorkbook.FullName ‘返回当前工作簿路径和名(18) edRange.Rows.Count ‘当前工作表中已使用的行数(19) Rows.Count ‘猎取工作表的行数(注：考虑兼容性)(20) Sheets(Sheet1).Name= “Sum” 将Sheet1命名为Sum(21) ThisWorkbook.Sheets.Add Before:=Worksheets(1) 添加一个新工作表在第一工作表前(22) ActiveSheet.Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count) 将当前工作表移至工作表的最终(23) Worksheets(Array(“sheet1”,”sheet2”)).Select 同时选择工作表1和工作表2(24) Sheets(“sheet1”).Delete或Sheets(1).Delete 删除工作表1(25) ActiveShee edRange.FormatConditions.Delete ‘删除当前工作表中全部的条件格式(26) Cells.Hyperlinks.Delete ‘取消当前工作表全部超链接(27) ActiveCell.CurrentRegion.Select选择当前活动单元格所包含的范围，等同于快捷键Ctrl+A(28) Cells.Select ‘选定当前工作表的全部单元格(29) Range(“A1”).ClearContents 清除活动工作表上单元格A1中的内容。
EXCEL 常用的宏代码大全
EXCEL 常用的宏代码大全本示例为设置密码窗口(1)If Application.InputBox("请输入密码：") = 1234 Then[A1] = 1 '密码正确时执行Else: MsgBox "密码错误，即将退出！" '此行与第2行共同设置密码End If本示例为设置密码窗口(1)X = MsgBox("是否真的要结帐？", vbYesNo)If X = vbYes ThenClose本示例为设置工作表密码ActiveSheet.Protect Password:=641112 ' 保护工作表并设置密码ActiveSheet.Unprotect Password:=641112 '撤消工作表保护并取消密码'本示例关闭除正在运行本示例的工作簿以外的其他所有工作簿，并保存其更改内容。
For Each w In WorkbooksIf <> Thenw.Close SaveChanges:=TrueEnd IfNext w'每次打开工作簿时，本示例都最大化Microsoft Excel 窗口。
Application.WindowState = xlMaximized'本示例显示活动工作表的名称。
MsgBox "The name of the active sheet is " & '本示例保存当前活动工作簿的副本。
ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS"'下述过程激活工作簿中的第四张工作表。
Sheets(4).Activate'下述过程激活工作簿中的第1张工作表。
Worksheets(1).Activate'本示例通过将Saved 属性设为True 来关闭包含本段代码的工作簿，并放弃对该工作簿的任何更改。
使用按键精灵实现去除EXCEL表某些字符的代码
使用按键精灵实现去除某些字符的代码
比如ＥＸＣＥＬ里面有５０列，每一列包含有"(1)"至"(50)"和文本的组合，就是说比如有一列标题是“(1)(13)(17)(18)(22)(40)(50)出生日期”，那么如果手动一个个删掉只留下文本，那么就要点时间来删，现在我们利用按键精灵去除。
前提条件：电脑要安装按键精灵软件和懒人办公插件（具体用这几个字百度一下就知道）
按键精灵代码如下：
//打开表****************************************
path = "C:\Users\Administrator\Desktop\text.xls"//意思是这个ＥＸＣＥＬ文档放在桌面
index = zyOffice.ExcelOpen(path, 1)
Delay 500
Dim txt(50)//表示一个包含50个数组元素的名为txt的数组
//去掉从1列到50列包含（1）到（50）的字符
For i = 1 To 50
txt(i) = zyOffice.ExcelRead(1, 1, i, index)
For m = 1 To 50
txt(i)=Replace(txt(i), "("&m&")", "", 1, - 1 , 1)
Next
Next
//写入从1列到50列的数据
For n = 1 To 50
Call zyOffice.ExcelWrite(1, 1, n,txt(n) , index)
Next。
excel 禁用条件格式 vba
题目：Excel中禁用条件格式VBA正文：在Excel中，条件格式是一种非常常用的功能，它可以根据某些规则自动对单元格进行格式化，使数据呈现出更直观的效果。
而VBA （Visual Basic for Applications）则是Excel中的一种编程语言，可以通过编写VBA代码来实现自动化的操作。
但是在某些情况下，我们可能需要禁用或取消已经设定的条件格式，那么该如何通过VBA来实现呢？下面我们将介绍一些常用的方法，供大家参考：1. 使用VBA取消单元格的条件格式在Excel中，我们可以通过以下的VBA代码来取消指定单元格的条件格式：```Sub CancelConditionalFormat()Range("A1").FormatConditions.DeleteEnd Sub```以上代码中，Range("A1")表示要取消条件格式的单元格范围，FormatConditions.Delete表示删除该单元格的所有条件格式。
2. 使用VBA取消工作表的条件格式如果我们需要取消整个工作表的条件格式，可以使用以下的VBA代码：```Sub CancelSheetConditionalFormat()With Sheets("Sheet1").Cells.FormatConditions.DeleteEnd WithEnd Sub```以上代码中，Sheets("Sheet1").Cells表示要取消条件格式的工作表范围，FormatConditions.Delete表示删除该工作表的所有条件格式。
3. 使用VBA禁用或启用条件格式有时候，我们可能并不想完全取消条件格式，而是希望仅仅禁用或启用它。
在这种情况下，可以使用以下的VBA代码实现：```Sub DisableConditionalFormat()Range("A1").FormatConditions(1).Enabled = FalseEnd Sub```以上代码中，Range("A1").FormatConditions(1).Enabled = False表示禁用单元格A1的第一个条件格式，如果需要启用条件格式，则将False改为True即可。
EXCEL VB常用宏代码集
#标题#:EXCEL VB常用宏代码集教你玩转EXCEL的VBA阻止另存为命令的使用本示例将阻止在工作簿中选择菜单“文件——另存为”命令的使用。
当您选择“另存为”命令后，将会弹出一个消息框，告诉您不能使用另存为命令更改工作簿的名称。
但您可以对该工作簿进行重命名。
下面的代码放置在ThisWorkbook代码模块中：‘*****************************************************Private Sub workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)Dim lReply As LongIf SaveAsUI = True ThenlReply = MsgBox("对不起,您不能用其它名称保存本工作簿. ", vbQuestion + vbOKCancel)Cancel = (lReply = vbCancel)If Cancel = False Then Me.SaveCancel = TrueEnd IfEnd Sub阻止用户打印工作簿本示例演示当用户试图进行"打印预览"或"打印"时，将弹出不能打印本工作簿的消息框，因而不能对该工作簿进行打印预览或打印操作。
下面的代码放置在ThisWorkbook代码模块中：‘*****************************************************Private Sub workbook_BeforePrint(Cancel As Boolean)Cancel = TrueMsgBox "对不起,您不能打印本工作簿.", vbInformationEnd Sub阻止打印工作簿中的部分工作表本程序将阻止用户打印工作簿中的部分工作表，即在这些工作表中(如工作表Sheet1和Sheet2)使用“打印预览”和”打印”功能时，将弹出不能打印的消息框。
VBA-EXCEL工作表代码
工作表1、'隐藏SHEET1这张工作表sheets("sheet1").Visible=False2、'显示SHEET1这张工作表sheets("sheet1").Visible=True3、'同时选择工作表1和工作表2Worksheets(Array(“sheet1”,”sheet2”)).Select4、'删除工作表1 Sheets(“sheet1”).Delete或Sheets(1).Delete5、'将该表格保存到C:\test.xls 目录ExcelSheet.SaveAs "C:\TEST.XLS"6、'在第1工作表前添加新工作表Sheets.Add before:=Sheets(1)7、'在最后工作表后添加新工作表Sheets.Add after:=Sheets(Sheets.Count)8、'删除当前工作表ActiveWindow.SelectedSheets.Delete可以用以下语句删除当前工作表。
ActiveSheet.Delete9、保护工作表使其不至被修改。
Sheets(“工作表名”).Protect (Password)10、撤销工作表保护使其被修改。
Sheets(“工作表名”).Unprotect (Password)示例：Sheets(“sheet1”).Protect “123456”Sheets(“sheet1”).Unprotect “123456”11、添加工作表Sheets.Add12、当前工作表命名 = "www"13、选定下（上）一个工作表sheets(activesheet.index-1).select sheets(activesheet.index+1).select 14、'取消工作表标签ActiveWindow.DisplayWorkbookTabs = False15、'格式＿工作表不能重命名mandBars("Sheet").Controls(1).Enabled= False16、'取消工作表标签ActiveWindow.DisplayWorkbookTabs = False17、'右键菜单不能重命名mandBars.FindControl(ID:=889).Enabled = False18、'工作表加密Worksheets（″基础数据表″）.Protect Password:="1234"19、'深度隐藏工作表Sheet1.Visible = 220、'显示工作表Sheet1.Visible = -121、‘当前工作表中已使用的行数edRange.Rows.Count22、Rows.Count ‘获取工作表的行数(注：考虑向前兼容性)23、Sheets(Sheet1).Name= “Sum”'将Sheet1命名为Sum24、ThisWorkbook.Sheets.Add Before:=Worksheets(1) '添加一个新工作表在第一工作表前25、ActiveSheet.Move After:=ActiveWorkbook. _Sheets(ActiveWorkbook.Sheets.Count) '将当前工作表移至工作表的最后26、Sheets(“sheet1”).Delete或Sheets(1).Delete '删除工作表127、ActiveWorkbook.Sheets(i).Name '获取工作表i的名称28、'切换工作表中的网格线显示，这种方法也可以用在其它方面进行相互切换，即相当于开关按钮ActiveWindow.DisplayGridlines=Not ActiveWindow.DisplayGridlines 29、‘切换工作表中的行列边框显示ActiveWindow.DisplayHeadings=Not ActiveWindow.DisplayHeadings 30、edRange.FormatConditions.Delete ‘删除当前工作表中所有的条件格式31、'将页面设置更改为横向ActiveSheet.PageSetup.Orientation=xlLandscape或ActiveSheet.PageSetup.Orientation=232、‘在页面设置的表尾中输入文件路径ActiveSheet.PageSetup.RightFooter=ActiveWorkbook.FullName33 ‘将用户名放置在活动工作表的页脚ActiveSheet.PageSetup.LeftFooter=erName34、‘两个关键字排序，相邻两列，B列为主关键字，A列为次关键字，升序排列ActiveSheet.Range("A:B").Sort Key1:=Columns("B"), Key2:=Columns("A"), _ Header:=xlYes 35、'开启数据记录单ActiveS heet.ShowDataForm工作簿1、定制自己的状态栏Application.StatusBar = "现在时刻: " & Time2、恢复自己的状态栏Application.StatusBar = false3、关闭屏幕更新Application.ScreenUpdate=False4、'打开屏幕刷新Application.ScreenUpdating=True5、删除一个文件kill "c:\1.txt"6、'退出EXCEL Application.Quit7、‘将文本写到状态栏Application.StatusBar=”请等待……”8、‘更新状态栏文本，以变量Percent代表完成的百分比Application.StatusBar=”请等待……”& Percent & “% Completed”9、MkDir "D:\Music" 建立文件夹的方法10、打开文件夹的方法ActiveWorkbook.FollowHyperlink Address:="D:\Music", NewWindow:=True11、'以本工作表名称另存文件到当前目录ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & & ".xls"12、新建Workbooks.Add打开Workbooks.Open "路径\" & "文件名 .xls"13、关闭同时保存Workbooks("filename.xls").Close savechanges:=True14、.关闭同时不保存Workbooks("filename.xls").Close savechanges:=False15、.Excel程序的关闭Application.Quit16、关闭Excel的警告提示。
如何利用VBA代码，屏蔽EXCEL工作表的复制功能
如何利用VBA代码，屏蔽EXCEL工作表的复制功能大家好，我们今日继续讲解VBA代码解决方案的第50讲内容：如何利用VBA代码，有效的屏蔽工作表的复制功能。
为什么要进入这节的内容呢？因为有时我们并不希望用户对工作表中的数据进行复制粘贴操作，这些是我的私有财产，不能让人轻易的获得，那么该怎么办呢？此时我们可以把所有的复制功能都屏蔽掉，这里会利用三个知识点一：CommandBars对象的FindControl方法。
应用于CommandBars对象的FindControl方法返回一个符合指定条件的CommandBarControl对象。
语法如下：expression.FindControl(Type, Id, Tag, Visible, Recursive) 参数a) expression是必需的，返回一个CommandBars对象。
b) Type是可选的，要查找控件的类型。
c) Id是可选的，要查找控件的标识符。
d) Tag是可选的，要查找控件的标记值。
e) Visible是可选，如果该值为True，那么只查找屏幕上显示的命令栏控件。
默认值为False。
f) Recursive是可选的，如果该值为True，那么将在命令栏及其全部弹出式子工具栏中查找。
此参数仅应用于CommandBar对象。
默认值为False。
特别注意：如果没有控件符合搜索条件，那么FindControl方法返回Nothing。
二：利用CellDragAndDrop 属性设置单元格的拖放功能，如果允许使用单元格拖放功能，则该值为True，如果不允许则该值设为false.三：关于应用于Application 对象的OnKey方法，这个知识点在我之前的文章中讲解过，这里给大家复习一下：应用于Application 对象的OnKey方法指定特定键或特定的组合键运行的过程，语法如下：expression.OnKey(Key, Procedure)参数：a) expression是必需的，该表达式返回一个Application 对象。
excl禁止关闭工作表
批量制作禁用宏就关闭的文件取材于老刀平常我们在打开带有宏的文件时，如果宏的安全性选择了中级时，我们选择启用宏或禁用宏，但在有些时候我们并不希望禁用宏，这时怎么做呢？我们知道，Excel的宏表函数是不能禁用了，所以下面我们就利用这个特性来设定。
首选插入一个名为“Macro”的宏表，在A2：A8中分别键入下面几行内容：=ERROR(FALSE)=RUN("RunMacro")=IF(ISERROR($A$3))=GOTO($A$11)=END.IF()=ERROR(TRUE)=RETURN()在A11：A13中分别键入以下几行内容：=ALERT("对不起!由于禁用了宏,本文件禁止打开!",3)=FILE.CLOSE(FALSE)=RETURN()下一步是在每一个工作表中插入一个名为“工作表名称!Auto_Activate”，引用位置为“=Macro!$A$2”的名称，如当前工作表名称为“Sheet1”，则插入名称为“Sheet1!Auto_Activate”。
保存之后就可以实现我们的功能了。
下面是做好的一个文件：根据上面的知识试着做一个加载宏，主要方便多个工作表时，设定名称。
加载后在工具菜单中生成相应的菜单项。
如果你是ExcelXP，在工具/宏/安全性里的可靠来源中，“信任对于Visual Basic 项目的访问”选项要选取。
加载宏后在工具菜单中有新菜单[EXCEL]禁用宏则退出时间:2009-04-09 17:20来源:铿亮工作室作者:SiliconXu 点击:199次这篇文章说明如何利用宏表，制作一个工作簿。
在用户打开工作簿时，Excel会提示用户是否允许运行宏，如果用户点击禁止的话，则Excel会提示由于禁止了宏的运行，本文件将要关闭，并这篇文章说明如何利用宏表，制作一个工作簿。
在用户打开工作簿时，Excel会提示用户是否允许运行宏，如果用户点击“禁止”的话，则Excel会提示“由于禁止了宏的运行，本文件将要关闭”，并关闭工作簿，以此达到强制要求用户打开工作簿时必须允许宏运行的目的。
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
为 False:
如果打开文件自动屏蔽,把屏蔽代码放入 Workbook_Open 事件中， 值
Private Sub Workbook_Open() ……
End Sub
如果想自动恢复,把恢复代码放入 Workbook_BeforeClose 事件中，值为 True： Private Sub Workbook_BeforeClose(Cancel As Boolean) ……
择性粘贴(&S)...").Enabled = False
mandBars(1).Controls("
编
辑
(&E)").Controls("office 剪贴板(&B)...").Enabled = False
End Sub
mandBars(1).Controls(" 工 具 (&T)").Controls(" 宏 (&M)").Enabled = False '工具-宏变成灰色，如忘了变回来，工具-自定义 -工具栏选项-工作表菜单栏-重新设置即可
(&V)").Enabled = False
'右键工作薄“查看代码”为灰色
'常用的屏蔽代码： mandBars("Worksheet '屏蔽菜单栏 Application.DisplayFormulaBar = False Application.DisplayStatusBar = False
Menu
Bar").Enabled = False
'屏蔽编辑栏 '屏蔽状态栏
下面任选一组即可，不可同时出现。
mandBars("Standard").Visible = False 屏蔽常用工具栏，右键可选
mandBars("Formatting").Visible = False 屏蔽格式工具栏，右键可选
'
mandBars("Visual basic").Enabled = False 屏蔽应用程序的<命令块>("Visual basic" )的激活
'
Application.OnKey
"%{f11}",
(&S)...").Enabled = False
mandBars(1).Controls(" 编 辑 (&E)").Controls(" 粘
贴(&P)").Enabled = False
mandBars(1).Controls(" 编 辑 (&E)").Controls(" 选
mandBars(3).Controls("粘贴(&P)").Enabled = False
mandBars.DisableCustomize = True
mandBars(1).Controls(" 工 具 (&T)").Controls(" 自
定义(&C)...").Enabled = False
Application.OnKey "^v", ""
' 禁 用 键 盘
"Ctrl+V"
Application.OnKey "^v"
'恢复键盘"Ctrl+V"
mandBars("Toolbar list").Enabled = False 屏蔽右键工具栏
'
mandBars("cell").Enabled = False 屏蔽单元格右键单击
'
mandBars.DisableAskAQuestionDropdown = True '去除工作表 右上角的帮助栏
mandBars("Reviewing").Visible = False 审阅
'屏蔽
mandBars("Formula Auditing").Visible = False '屏蔽 公式审核
'屏蔽工作
ActiveWindow.DisplayVerticalScrollBar = False 条
'屏蔽垂直滚动
ActiveWindow.DisplayHorizontalScrollBar = False 条
'屏蔽水平滚动
mandBars("ply").Enabled = FalLT+F11，%代表 ALT
"
"
Application.OnKey "%{F11}" 解除屏蔽 ALT+F11
'
Application.OnKey '屏蔽组合键 ALT+F8
"%{f8}",
"
恢复组合键 Ctrl+F11,插入宏表
Application.OnKey
"^f",
'屏蔽组合键 Ctrl+F，查找
Application.OnKey
"^h",
'屏蔽组合键 Ctrl+H，替换
Application.OnKey
"^{Break}",
"VBEdit"
'
"
"
"
"
"
"
'屏蔽 CTRL+Break 中断 Application.OnKey "^{Break}" 解除 CTRL+Break 中断
'
'屏蔽“菜单”中的项： mandBars(1).Controls(" 文 件 (&F)").Enabled = False '屏蔽文件菜单 mandBars(1).Controls(" 编 辑 (&E)").Enabled = False '屏蔽编辑菜单 mandBars(1).Controls(" 视 图 (&V)").Enabled = False '屏蔽视图菜单 mandBars(1).Controls(" 插 入 (&I)").Enabled = False '屏蔽插入菜单 mandBars(1).Controls(" 格 式 (&O)").Enabled = False '屏蔽格式菜单 mandBars(1).Controls(" 工 具 (&T)").Enabled = False '屏蔽工具菜单 mandBars(1).Controls(" 数 据 (&D)").Enabled = False '屏蔽数据菜单 mandBars(1).Controls(" 窗 口 (&W)").Enabled = False '屏蔽窗口菜单 mandBars(1).Controls(" 帮 助 (&H)").Enabled = False '屏蔽帮助菜单
mandBars("ply").Controls(" 查 看 代 码
(&V)").Enabled = False
'右键工作表标签“查看代码”为灰色
mandBars("Document").Controls(" 查 看 代 码
'禁用粘贴:
mandBars("Cell").Controls("