EXCEL VBA 实用代码收集.doc

图片切换Sub 显示开或关() If ActiveSheet.Shapes(Picture 2).Visible = True Then ActiveSheet.Shapes(Picture 1).Visible = True ActiveSheet.Shapes(Picture 2).Visible = False ElseActiveSheet.Shapes(Picture 2).Visible = TrueActiveSheet.Shapes(Picture 1).Visible = False End IfEnd Sub当前单元格输入数字自动分解Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column 1 Then Exit Sub If Len(Target(1, 1) 1 Then Dim oJs As Object Set oJs = CreateObject(ScriptControl): oJs.Language = JScript Target(1, 2).Resize(1, 254).ClearContents Target.Resize(1, Len(Target) = Split(oJs.eval( & Target & .match(/./g);), ,) End IfEnd Subword批量修改图片大小固定长宽Sub setpicsize() 设置图片大小Dim n图片个数On Error Resume Next 忽略错误For n = 1 To ActiveDocument.InlineShapes.Count InlineShapes类型图片ActiveDocument.InlineShapes(n).Height = 400 设置图片高度为 400pxActiveDocument.InlineShapes(n).Width = 300 设置图片宽度 300pxNext nFor n = 1 To ActiveDocument.Shapes.Count Shapes类型图片ActiveDocument.Shapes(n).Height = 400 设置图片高度为 400pxActiveDocument.Shapes(n).Width = 300 设置图片宽度 300pxNext nEnd Sub批量修改图片大小按比例缩放篇Sub setpicsize() 设置图片大小Dim n图片个数Dim picwidthDim picheightOn Error Resume Next 忽略错误For n = 1 To ActiveDocument.InlineShapes.Count InlineShapes类型图片picheight = ActiveDocument.InlineShapes(n).Heightpicwidth = ActiveDocument.InlineShapes(n).WidthActiveDocument.InlineShapes(n).Height = picheight * 1.1 设置高度为1.1倍ActiveDocument.InlineShapes(n).Width = picwidth * 1.1 设置宽度为1.1倍Next nFor n = 1 ToActiveDocument.Shapes.Count Shapes类型图片picheight = ActiveDocument.Shapes(n).Heightpicwidth = ActiveDocument.Shapes(n).WidthActiveDocument.Shapes(n).Height = picheight * 1.1 设置高度为1.1倍ActiveDocument.Shapes(n).Width = picwidth * 1.1 设置宽度为1.1倍Next nEnd Sub批量给图片加边框Dim i As IntegerFor i = 1 To ActiveDocument.InlineShapes.CountWith ActiveDocument.InlineShapes(i)With .Borders(wdBorderLeft).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderRight).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderTop).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd With.Borders.Shadow = FalseEnd WithWith Options.DefaultBorderLineStyle = wdLineStyleSingle.DefaultBorderLineWidth = wdLineWidth100pt.DefaultBorderColor = wdColorAutomaticEnd WithNext i锁定文件名Private Sub Workbook_Open()If ThisWorkbook.Name 三八节.xls ThenApplication.DisplayAlerts = FalseApplication.QuitEnd IfEnd Sub将数值转换为文本程序扩展 可以将程序代码1和程序代码2略加改动，将一个字符附加到所选单元格的开头。如将cell.Value = & cell.Value换成cell.Value=”I”&cell.Value，则在所选单元格开头添加字符“I”，即可统一单元格开始形式。程序代码1Sub 数值转换为文本1() 通过添加号 Dim cell As Range For Each cell In Selection If Not cell.HasFormula Then If Not IsEmpty(cell) Then cell.Value = & cell.Value End If End If NextEnd Sub程序代码2Sub 数值转换成文本2() 只对数字单元格进行操作 Dim cell As Range For Each cell In Selection If Not cell.HasFormula Then If Not IsEmpty(cell) Then If IsNumeric(cell) Then cell.Value = & cell.Value 可根据需要变换字符 End If End If End If NextEnd Sub程序代码3Sub 数值转换为文本3() 通过格式 Dim cell As Range For Each cell In Selection If Not cell.HasFormula Then If Not IsEmpty(cell) Then Selection.NumberFormatLocal = End If End If NextEnd Sub关闭并保存所有工作簿 Option Explicit Sub CloseAllWorkbooks() Dim Book As Workbook For Each Book In WorkbooksIf Book.NameThisWorkbook.Name Then Book.Close savechanges:=True End If Next Book ThisWorkbook.Close savechanges:=True End Sub 关闭工作簿并将它彻底删除 Option ExplicitSub KillMe() With ThisWorkbook .Saved = True .ChangeFileAccess Mode:=xlReadOnly Kill .FullName .Close False End WithEnd SubA列输出排列组合Sub pailie()Dim s As String, x() As StringDim starttime As Single, endtime As SingleDim i As Long, j As Integer, k As Integer, Num As Long, n As IntegerDim ALL(), TEMP1 As Long, TEMP2 As Long, arr() As Strings = InputBox(请输入不重复的字母或数字)n = Len(s) 元素个数ReDim x(n - 1)For i = 1 To nx(i - 1) = Mid(s, i, 1)Nextstarttime = Timer 开始计时Num = 1For i = 1 To nNum = Num * i递归计算n！NextReDim arr(1 To Num, 1 To 1)For i = 1 To NumReDim ALL(1 To n) 初始化数组allALL(1) = x(0)TEMP1 = iFor j = 2 To nTEMP2 = TEMP1 Mod jTEMP1 = TEMP1 jIf TEMP2 = 0 ThenALL(j) = x(j - 1) temp2为 0则放在最后ElseFor k = j To TEMP2 + 1 Step -1ALL(k) = ALL(k - 1) temp2之后的元素后移一位NextALL(TEMP2) = x(j - 1) temp2不为 0 则置于第temp2个元素前End IfNextarr(i, 1) = Join(ALL, ) 输出Nextendtime = TimerApplication.ScreenUpdating = FalseRange(a1).Resize(Num, 1) = arrApplication.ScreenUpdating = TrueMsgBox 共 & Num & 种排列！用时 & endtime - starttime & 秒！End Sub同薄汇总工作表Sub mysub()Application.ScreenUpdating = FalseDim sh As Worksheet, aa As Long, bb As Long, cc As Long, dd As Longdd = Sheets(汇总).IV1.End(1).ColumnSheets(汇总).Range(Cells(2, 2), Cells(65536, dd).ClearContentsFor Each sh In Worksheets If sh.Name 汇总 Then bb = Sheets(汇总).b65536.End(xlUp).Row + 1 aa = sh.b65536.End(xlUp).Row cc = sh.IV1.End(1).Column sh.Range(sh.Cells(2, 2), sh.Cells(aa, cc).Copy Sheets(汇总).Cells(bb, 2).PasteSpecial xlPasteValues End If Next shApplication.ScreenUpdating = TrueEnd Sub异薄SHEET1汇总Private Sub CommandButton2_Click() Application.ScreenUpdating = False Dim i&, LastRow&, Path$, FileName$, TWB$, WB As Workbook Path = ThisWorkbook.Path & FileName = Dir(Path & *.xls) TWB = ThisWorkbook.Name Range(A1:X65536).ClearContents Do While Len(FileName) If FileName TWB Then Set WB = Workbooks.Open(Path & FileName) With WB.Worksheets(1) LastRow = .Range(A65536).End(xlUp).Row If LastRow 1 Then .Range(A8:x8).Copy ThisWorkbook.Sheets(汇总).Range(A65536).End(xlUp)(2).PasteSpecial Paste:=xlValue End If End With Application.CutCopyMode = False WB.Close True End If FileName = Dir() Loop Range(A1).Select Set WB = Nothing Application.ScreenUpdating = TrueEnd Sub异薄汇总工作表Private Sub CommandButton2_Click() Application.ScreenUpdating = False Dim i&, LastRow&, Path$, FileName$, TWB$, WS As Worksheet, WB As Workbook Path = ThisWorkbook.Path & FileName = Dir(Path & *.xls) TWB = ThisWorkbook.Name Range(A1:X65536).ClearContents Do While Len(FileName) If FileName TWB Then Set WB = Workbooks.Open(Path & FileName) For Each WS In WB.Worksheets LastRow = WS.Range(A65536).End(xlUp).Row If LastRow 1 Then WS.Range(A8:x & LastRow).Copy 复制A8：X列&最后有数据的列 ThisWorkbook.Sheets(汇总).Range(A65536).End(xlUp)(2).PasteSpecial Paste:=xlValue 粘贴到“汇总”表，从下往上数有数据的列的下一列 End If Next Application.CutCopyMode = False WB.Close True End If FileName = Dir() Loop Range(A1).Select Set WB = Nothing Application.ScreenUpdating = TrueEnd Sub调用实例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填充成组工作表选项按钮输入单元格Private Sub CommandButton1_Click() For Each sp In Me.Frame1.Controls 在窗体(me)中的Frame1内的所有控件进行遍历 If sp Then Sheet1.a3 = sp.Caption 如果某个被选中，则将该选项按钮的Caption写入工作表Sheet1的a3单元格 NextEnd SubPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 1. 直接关闭窗体应是不用保存的了(或给个提示,是否要保存) If MsgBox(是否保存选项, vbYesNo) = vbOK Then For Each sp In Me.Frame1.Controls CommandButton1_Click Next End IfEnd Sub获取屏幕分辨率Sub fenbianlv()strComputer = .Set objWMIService = GetObject(winmgmts: _ & impersonationLevel=impersonate! & strComputer & rootcimv2)Set colSettings = objWMIService.ExecQuery _ (Select * from Win32_DesktopMonitor)For Each objScreen In colSettings MsgBox 屏幕高： & objScreen.ScreenHeight & vbCrLf _ & 屏幕宽： & objScreen.ScreenWidthNextEnd Sub不输入显示灰色字体，输入显示输入内容Sheet1:Private Sub Worksheet_SelectionChange(ByVal Target As Range)Call MEnd Sub模块：Sub M() If Range(B3) = Then Range(B3) = 请在此处输入姓名 Range(B3).Font.ColorIndex = 16 ElseIf Range(B3) 请在此处输入姓名 And Range(B3) Then Range(B3).Font.ColorIndex = 1 End IfEnd Sub点击单元格自动求和Sheet1:Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Row = 3 ThenTarget.Value = Application.WorksheetFunction.Sum(Range(Cells(4, Target.Column), Cells(65536, Target.Column)End IfEnd Sub根据第一个工作表A列内容自动创建相应工作表Sub CreatMySheets() Dim m As Range, str As String, created As Boolean On Error GoTo ErrorHandler For Each m In Range(A1, Cells(Cells.SpecialCells(xlLastCell).Row(), 1) str = m.Text If str Then If Not created Then ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) End If created = False ActiveSheet.Name = str End If Next m On Error GoTo 0 Set m = Nothing Application.DisplayAlerts = False If created Then ActiveSheet.Delete Application.DisplayAlerts = True Exit SubErrorHandler: created = True Resume NextEnd SubPrivate Sub TextBox1_Change() If TextBox1 S And TextBox1 N And TextBox1 E And TextBox1 W Then MsgBox 错误的输入,即将被删除 TextBox1 = End IfEnd Sub定义变量：Dim 变量名 As 数据类型Option Explict作为第一句语句强制声明所有变量Dim或Static语句 本地变量（作用此过程）Dim或Prvate语句 模块作用域下的变量（作用此模块）Public 公有变量（作用所有模块）定义常量：Const 常量名 As 数据类型 常量的值声明数组Dim/Public 数组名 (a to b) as 数据类型调用函数前面加上application.worksheetfunction在VBA里使用counta函数则代码为： application.worksheetfunction.counta(range(a1:a10) Sub myabs() a = InputBox(请输入数值：, 提示) labs = Abs(a) MsgBox 你输入的值的绝对值为: & labs End Sub闪动字符Private Declare Sub Sleep Lib kernel32 (ByVal dwMilliseconds As Long)Sub t()Dim str$, i%str = 祝你生日快乐 & 祝你生日快乐For i = 1 To Len(str)a1 = Mid(str, i, 1)With a1.Font .Size = 18 .Color = vbRedEnd WithSleep 500Next iEnd Sub截取指定字符前内容Sub m() Dim eR& eR = A65535.End(xlUp).Row For i = 2 To eR Ar = Split(Cells(i, 1), C2) 按指定符号取值 Cells(i, 2) = Ar(0) Next i End Sub按颜色汇总Public Function COLOR(ByVal X As Range, Y)For Each I In X If I.Font.ColorIndex = Y Then COLOR = COLOR + I End IfNext IEnd Function统计红色,输入：=COLOR(a1:b10,3)统计蓝色,输入：=COLOR(a1:b10,5)如果打开文件自动屏蔽,把屏蔽代码放入Workbook_Open事件中， 值为False:Private Sub Workbook_Open()End Sub如果想自动恢复,把恢复代码放入Workbook_BeforeClose事件中，值为True：Private Sub Workbook_BeforeClose(Cancel As Boolean)End SubApplication.CommandBars(1).Controls(工具(&T).Controls(宏(&M).Enabled = False 工具-宏变成灰色，如忘了变回来，工具-自定义-工具栏选项-工作表菜单栏-重新设置即可Application.CommandBars(ply).Controls(查看代码(&V).Enabled = False 右键工作表标签“查看代码”为灰色Application.CommandBars(Document).Controls(查看代码(&V).Enabled = False 右键工作薄“查看代码”为灰色常用的屏蔽代码：Application.CommandBars(Worksheet Menu Bar).Enabled = False 屏蔽菜单栏Application.DisplayFormulaBar = False 屏蔽编辑栏Application.DisplayStatusBar = False 屏蔽状态栏下面任选一组即可，不可同时出现。Application.CommandBars(Standard).Visible = False 屏蔽常用工具栏，右键可选Application.CommandBars(Formatting).Visible = False 屏蔽格式工具栏，右键可选Application.CommandBars(Standard).Enabled = False 去除常用工具栏，右键也删掉Application.CommandBars(Formatting).Enabled = False 去除格式工具栏，右键也删掉Application.CommandBars(Toolbar list).Enabled = False 屏蔽右键工具栏Application.CommandBars(cell).Enabled = False 屏蔽单元格右键单击Application.CommandBars(Column).Enabled = False 屏蔽列右键单击Application.CommandBars(Row).Enabled = False 屏蔽行右键单击Application.Assistant.Visible = False 应用程序的辅助的可见Application.CommandBars.DisableCustomize = True 去除右键工具栏中的“自定义”ActiveWindow.DisplayHeadings = False 屏蔽行号列标ActiveWindow.DisplayWorkbookTabs = False 屏蔽工作表标签ActiveWindow.DisplayVerticalScrollBar = False 屏蔽垂直滚动条ActiveWindow.DisplayHorizontalScrollBar = False 屏蔽水平滚动条Application.CommandBars(ply).Enabled = False 屏蔽工作表标签右键单击Application.CommandBars(Visual basic).Enabled = False 屏蔽应用程序的(Visual basic )的激活Application.OnKey %f11, 屏蔽组合键ALT+F11，%代表ALTApplication.OnKey %F11 解除屏蔽ALT+F11Application.OnKey %f8, 屏蔽组合键ALT+F8Application.OnKey %f8 解除屏蔽ALT+F8Application.OnKey f11, VBEdit 屏蔽组合键Ctrl+F11,插入宏表，代表CtrlApplication.OnKey f11 恢复组合键Ctrl+F11,插入宏表Application.OnKey f, 屏蔽组合键Ctrl+F，查找Application.OnKey h, 屏蔽组合键Ctrl+H，替换Application.OnKey Break, 屏蔽CTRL+Break中断Application.OnKey Break 解除CTRL+Break中断屏蔽“菜单”中的项：Application.CommandBars(1).Controls(文件(&F).Enabled = False 屏蔽文件菜单Application.CommandBars(1).Controls(编辑(&E).Enabled = False 屏蔽编辑菜单Application.CommandBars(1).Controls(视图(&V).Enabled = False 屏蔽视图菜单Application.CommandBars(1).Controls(插入(&I).Enabled = False 屏蔽插入菜单Application.CommandBars(1).Controls(格式(&O).Enabled = False 屏蔽格式菜单Application.CommandBars(1).Controls(工具(&T).Enabled = False 屏蔽工具菜单Application.CommandBars(1).Controls(数据(&D).Enabled = False 屏蔽数据菜单Application.CommandBars(1).Controls(窗口(&W).Enabled = False 屏蔽窗口菜单Application.CommandBars(1).Controls(帮助(&H).Enabled = False 屏蔽帮助菜单屏蔽“菜单”中的子项：Application.CommandBars(1).Controls(编辑(&E).Controls(填充(&I).Enabled = False 屏蔽“编辑”菜单中的“填充”项Application.CommandBars(1).Controls(工具(&T).Controls(选项(&O).).Visible = False 去除工具-选项Application.CommandBars(1).Controls(工具(&T).Controls(选项(&O).).Enabled = False 工具-选项变灰色禁用粘贴:Application.CommandBars(Cell).Controls(粘贴(&P).Enabled = False 禁用右键粘贴Application.CommandBars(Cell).Controls(选择性粘贴(&S).).Enabled = FalseApplication.CommandBars(1).Controls(编辑(&E).Controls(粘贴(&P).Enabled = FalseApplication.CommandBars(1).Controls(编辑(&E).Controls(选择性粘贴(&S).).Enabled = FalseApplication.CommandBars(1).Controls(编辑(&E).Controls(office 剪贴板(&B).).Enabled = FalseApplication.CommandBars(3).Controls(粘贴(&P).Enabled = FalseApplication.CommandBars.DisableCustomize = TrueApplication.CommandBars(1).Controls(工具(&T).Controls(自定义(&C).).Enabled = FalseApplication.OnKey v, 禁用键盘Ctrl+VApplication.OnKey v 恢复键盘Ctrl+VApplication.CommandBars.DisableAskAQuestionDropdown = True 去除工作表