excel宏文件集.docx

1、excel宏文件集打开全部隐藏工作表Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.Count Sheets(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 如果名为完成标志的命名

2、单元的值等于完成,则退出循环,如果一开始就等于完成,则只执行一次循环就退出If Sheets(传送参数).Range(A & i).Text = 完成 Then Exit For 如果某列出现完成内容则退出循环Next iEnd Sub录制宏时调用“停止录制”工具栏Sub 录制宏时调用停止录制工具栏()Application.CommandBars(Stop Recording).Visible = TrueEnd Sub高级筛选5列不重复数据至指定表Sub 高级筛选5列不重复数据至Sheet2()Sheets(Sheet2).Range(A1:E65536) = 清除Sheet2的A:D列R

3、ange(A1:E65536).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _ A1), Unique:=True Sheet2.Columns(A:E).Sort Key1:=Sheet2.Range(A2), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYinEnd Sub双击单元执行宏(工作表代码)Priva

4、te Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range($A$1) = 关闭 Then Exit SubSelect Case Target.Address Case $A$4 Call 宏1 Cancel = True Case $B$4 Call 宏2 Cancel = True Case $C$4 Call 宏3 Cancel = TrueCase $E$4 Call 宏4 Cancel = TrueEnd SelectEnd Sub双击指定区域单元执行宏(工作表代码)Pri

5、vate 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($

6、A$1) = 关闭 Then Exit SubSelect Case Target.Address Case $A$5 单元地址(Target.Address),或命名单元名字(Target.Name) Call 宏1 Case $B$5 Call 宏2 Case $C$5 Call 宏3 End SelectEnd Sub进入指定区域单元执行宏(工作表代码)Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range($A$1) = 关闭 Then Exit SubIf Not Application.Interse

7、ct(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_Cl

8、ick()With CommandButton1 If .Caption = 保护工作表 Then Call 保护工作表 .Caption = 取消工作表保护 Exit Sub End If If .Caption = 取消工作表保护 Then Call 取消工作表保护 .Caption = 保护工作表 Exit Sub End IfEnd WithEnd Sub在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1 If .Caption = 宏1 T

9、hen Call 宏1 .Caption = 宏2 Exit Sub End If If .Caption = 宏2 Then Call 宏2 .Caption = 宏3 Exit Sub End If If .Caption = 宏3 Then Call 宏3 .Caption = 宏1 Exit Sub End IfEnd WithEnd Sub根据A1单元文本隐藏/显示按钮（控件按钮代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range(A1) 2 ThenCommandButton1.Visible

10、 = 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 奇偶页分别打

11、印()Dim i%, Ps%Ps = ExecuteExcel4Macro(GET.DOCUMENT(50) 总页数MsgBox 现在打印奇数页,按确定开始.For i = 1 To Ps Step 2 ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox 现在打印偶数页,按确定开始.For i = 2 To Ps Step 2 ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub自动打印多工作表第一页Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim

12、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 = Ap

13、plication.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

14、) _ .Activate ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd SubSub 取消原分页() Cells.Select ActiveSheet.ResetAllPageBreaksEnd Sub将A列最后数据行以上的所有B列图片大小调整为所在单元大小Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小() Dim Pic As Picture, i& i = A65536.End(xlUp).Row For Each Pic In Sheet1.Pictures If Not Appli

15、cation.Intersect(Pic.TopLeftCell, Range(B1:B & i) Is Nothing Then Pic.Top = Pic.TopLeftCell.Top Pic.Left = Pic.TopLeftCell.Left Pic.Height = Pic.TopLeftCell.Height Pic.Width = Pic.TopLeftCell.Width End If NextEnd Sub返回光标所在行数Sub 返回光标所在行数()x = ActiveCell.RowRange(A1) = xEnd Sub在A1返回当前选中单元格数量Sub 在A1返回当

16、前选中单元格数量()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 nE

17、nd Sub返回A列数据的最大行数Sub 返回A列数据的最大行数()n = Range(a65536).End(xlUp).RowRange(B1) = nEnd Sub将所选区域文本插入新建文本框Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)Next ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + ActiveCell.

18、Height, 250#, 100).Select Selection.Characters.Text = 问题： & n With Selection.Characters(Start:=1, Length:=3).Font .Name = 黑体 .FontStyle = 常规 .Size = 12 End WithEnd Sub批量插入地址批注Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count 0 ThenFor Each r In Selectionr.Comment.Deleter.AddCo

19、mmentr.Comment.Visible = Falser.Comment.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.AddCommentr.Comment.Visible = Falser.Commen

20、t.Text Text:=msgNextEnd IfEnd Sub以A1单元内容批量插入批注Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count 0 ThenFor Each r In Selectionr.AddCommentr.Comment.Visible = Falser.Comment.Text Text:=a1.TextNextEnd IfEnd Sub不连续区域插入当前文件名和表名及地址Sub 批量插入当前文件名和表名及地址() For Each mycell In Selection mycell.FormulaR1

21、C1 = + ActiveWorkbook.Name + + ActiveSheet.Name + ! + mycell.Address NextEnd Sub不连续区域录入当前单元地址Sub 区域录入当前单元地址() For Each mycell In Selection mycell.FormulaR1C1 = mycell.Address NextEnd Sub连续区域录入当前单元地址Sub 连续区域录入当前单元地址() Selection = =ADDRESS(ROW(),COLUMN(),4,1) Selection.Copy Selection.PasteSpecial Past

22、e:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=FalseEnd Sub返回当前单元地址Sub 返回当前单元地址()d = ActiveCell.AddressA1 = dEnd Sub不连续区域录入当前日期Sub 区域录入当前日期() Selection.FormulaR1C1 = Format(Now(), yyyy-m-d) End Sub不连续区域录入当前数字日期Sub 区域录入当前数字日期() Selection.FormulaR1C1 = Format(Now(), yyyymmdd)End

23、 Sub不连续区域录入当前日期和时间Sub 区域录入当前日期和时间() Selection.FormulaR1C1 = Format(Now(), yyyy-m-d h:mm:ss) End Sub不连续区域录入对勾Sub 批量录入对勾()Selection.FormulaR1C1 = End Sub不连续区域录入当前文件名Sub 批量录入当前文件名()Selection.FormulaR1C1 = ThisWorkbook.NameEnd Sub不连续区域添加文本Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & 文本内容Next

24、End 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%,

25、 str1$ I = 1 Sheets(aa).Select Do While Cells(I, 1).Value str1 = Trim(Cells(I, 1).Value) Sheets(str1).Select Sheets(str1).Move after:=Sheets(I) I = I + 1 Sheets(aa).Select LoopEnd Sub以A1单元文本作表名插入工作表Sub 以A1单元文本作表名插入工作表() Dim nm As String nm = a1 Sheets.Add ActiveSheet.Name = nmEnd Sub删除全部未选定工作表Sub 删除

26、全部未选定工作表() Dim sht As Worksheet, n As Integer, iFlag As Boolean Dim ShtName() As String n = ActiveWindow.SelectedSheets.Count ReDim ShtName(1 To n) n = 1 For Each sht In ActiveWindow.SelectedSheets ShtName(n) = sht.Name n = n + 1 Next Application.DisplayAlerts = False For Each sht In Sheets iFlag =

27、False For i = 1 To n - 1 If ShtName(i) = sht.Name Then iFlag = True Exit For End If Next If Not iFlag Then sht.Delete Next Application.DisplayAlerts = TrueEnd Sub工作表标签排序Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox(工作表按升序排列请选 是Y. & vbCrLf & vbCrLf & 工作表按降序排列请选 否N, vbYe

28、sNoCancel, 工作表排序)If msg = vbCancel Then Exit Subnums = Sheets.Count If msg = vbYes Then Sort ascending For i = 1 To nums For j = i To nums If UCase(Sheets(j).Name) UCase(Sheets(i).Name) Then Sheets(j).Move Before:=Sheets(i) End If Next j Next i End IfEnd Sub定义指定工作表标签颜色Sub 定义指定工作表标签颜色()Sheets(Sheet1).Tab.ColorIndex = 46End Sub在目录表建立本工作簿中各表链接目录Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As Range On Error Resume Next Sheets(目录).Activate If Err = 0 Then Sheets(目录).UsedRange.Delete Else Sheets.Add ActiveSheet.Name = 目录 End If For i = 1 To Sheets.Count If Sheets(i).Name 目录 Then s = s + 1 S