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

《EXCEL VBA 实用代码收集(17页).doc》由会员分享，可在线阅读，更多相关《EXCEL VBA 实用代码收集(17页).doc（17页珍藏版）》请在淘文阁 - 分享文档赚钱的网站上搜索。

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 Objectnguage = JScript Target(1, 2).Resize(1, 254).ClearContents Target.Resize(1, Len(Target) = Split(oJs.eval( & Target & .match(/./g);), ,) End IfEnd Subword批量修改图片大小固定长宽Su

3、b 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类型图片ActiveDocumen

4、t.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 = Acti

5、veDocument.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).WidthActiveDoc

6、ument.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 = wdLineWidth100

7、pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderRight).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderTop).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd WithWith .Borders(wdBorderBotto

8、m).LineStyle = wdLineStyleSingle.LineWidth = wdLineWidth100pt.Color = wdColorAutomaticEnd With.Borders.Shadow = FalseEnd WithWith Options.DefaultBorderLineStyle = wdLineStyleSingle.DefaultBorderLineWidth = wdLineWidth100pt.DefaultBorderColor = wdColorAutomaticEnd WithNext i锁定文件名Private Sub Workbook_

9、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 Selec

10、tion 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 可根据需要变换字符

11、 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

12、 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 p

13、ailie()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)Nexts

14、tarttime = 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

15、 - 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()Appl

16、ication.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)

17、.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$, T

18、WB$, 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(汇总).R

19、ange(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

20、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

21、 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 =

22、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宏对话

23、框 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

24、).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选择性粘贴对话框 Applic

25、ation.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取

26、消或隐藏工作表选择对话框 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设置

27、图表颜色 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

28、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 = .S

29、et 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(ByVa

30、l 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 Then

31、Target.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).R

32、ow(), 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 R

33、esume 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 数据类型 常量

34、的值声明数组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 = 祝

35、你生日快乐 & 祝你生日快乐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 Rang

36、e, 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(Ca

37、ncel 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 右键工作薄“查看代码”为灰色

38、常用的屏蔽代码：Application.CommandBars(Worksheet Menu Bar).Enabled = False 屏蔽菜单栏Application.DisplayFormulaBar = False 屏蔽编辑栏Application.DisplayStatusBar = False 屏蔽状态栏下面任选一组即可，不可同时出现。Application.CommandBars(Standard).Visible = False 屏蔽常用工具栏，右键可选Application.CommandBars(Formatting).Visible = False 屏蔽格式工具栏，右键可选

39、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 屏蔽列右键单击A

40、pplication.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