EXCEL VBA 实用代码收集(17页).doc

-EXCEL VBA 实用代码收集-第 17 页图片切换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 Objectnguage = "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 Tohapes.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 Next nFor n = 1 ToActiveDocument.Shapes.Count 'Shapes类型图片picheight = ActiveDocument.Shapes(n).Heightpicwidth = ActiveDocument.Shapes(n).WidthActiveDocument.Shapes(n).Height = picheight * 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 Workbooks If Book.Name<>ThisWorkbook.Name Then   Book.Close savechanges:=True  End If Next Book ThisWorkbook.Close savechanges:=True End Sub 关闭工作簿并将它彻底删除 Option Explicit Sub KillMe() With ThisWorkbook   .Saved = True   .ChangeFileAccess Mode:=xlReadOnly Kill .FullName .Close False End With End 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 = False  Dim sh As Worksheet, aa As Long, bb As Long, cc As Long, dd As Long  dd = Sheets("汇总").IV1.End(1).Column  Sheets("汇总").Range(Cells(2, 2), Cells(65536, dd).ClearContents  For 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 sh  Application.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") 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").Copyheets("汇总").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") Range("A1:X65536").ClearContents Do While Len(FileName) If FileName <> TWB Then Set WB = Workbooks.Open(Path & FileName) 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 CommandButton1_Click Next End IfEnd Sub获取屏幕分辨率Sub fenbianlv()strComputer = "."Set objWMIService = GetObject("winmgmts:" _ & "impersonationLevel=impersonate!" & strComputer & "rootcimv2")y _ ("Select * from Win32_DesktopMonitor")For Each objScreen In colSettings MsgBox "屏幕高：" & objScreen.ScreenHeight & vbCrLf _NextEnd 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) 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 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 数据类型调用函数前面加上在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 iEnd 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，%代表ALTApplicatio