《EXCEL-VBA-实用代码收集(17页).doc》由会员分享，可在线阅读，更多相关《EXCEL-VBA-实用代码收集(17页).doc（17页珍藏版）》请在taowenge.com淘文阁网|工程机械CAD图纸|机械工程制图|CAD装配图下载|SolidWorks_CaTia_CAD_UG_PROE_设计图分享下载上搜索。
1、-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当前单元格输入数字
2、自动分解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 & .mat
3、ch(/./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 Activ
4、eDocument.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 InlineShape
5、s类型图片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 = Act
6、iveDocument.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
7、(i)With .Borders(wdBorderLeft).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderRight).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderTop).LineStyle = wdLineStyleSingle.L
8、ineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd With.Borders.Shadow = FalseEnd WithWith Options.DefaultBorderLineStyle = wdLineStyleSingle.DefaultBorderLineWidth = wdLineW
9、idth100pt.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，则在所选单元格开
10、头添加字符“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 The
11、n 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关
12、闭并保存所有工作簿 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 .Cha
13、ngeFileAccess 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 = InputB
14、ox(请输入不重复的字母或数字)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
15、= 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.ScreenUpdatin
16、g = 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 Workshee
17、ts 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 CommandB
18、utton2_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 & FileNam
19、e) 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 = Not
20、hing 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).ClearCo
21、ntents 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:=xlV
22、alue 粘贴到“汇总”表，从下往上数有数据的列的下一列 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是
23、删除文档 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.Dia
24、logs(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字体选择 Applicati
25、on.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
26、(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).Sho
27、w复制图片选项 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单变量求解 Appl
28、ication.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
29、 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! & strCompute
30、r & 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 Rang
31、e)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 = A
32、pplication.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
33、.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 S
34、ubErrorHandler: 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 公有变量（
35、作用所有模块）定义常量：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 kern
36、el32 (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) =
37、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如果想自动恢复,把恢复代码放入Workb
38、ook_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.CommandBa
39、rs(Document).Controls(查看代码(&V).Enabled = False 右键工作薄“查看代码”为灰色常用的屏蔽代码：Application.CommandBars(Worksheet Menu Bar).Enabled = False 屏蔽菜单栏Application.DisplayFormulaBar = False 屏蔽编辑栏Application.DisplayStatusBar = False 屏蔽状态栏下面任选一组即可，不可同时出现。Application.CommandBars(Standard).Visible = False 屏蔽常用工具栏，右键可选App
40、lication.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 屏蔽单元
41、格右键单击Application.CommandBars(Column).Enabled = False 屏蔽列右键单击Application.CommandBars(Row).Enabled = False 屏蔽行右键单击Application.Assistant.Visible = False 应用程序的辅助的可见Application.CommandBars.DisableCustomize = True 去除右键工具栏中的“自定义”ActiveWindow.DisplayHeadings = False 屏蔽行号列标ActiveWindow.DisplayWorkbookTabs = False