本文已参与[新人创作礼]活动,一起开启掘金创作之路
VBA代码大全-2（50个实例）
27、更新链接
ActiveWorkbook.UpdateLinkName:=ActiveWorkbook.LinkSources
28、设置滚动区域
Worksheets("大表格").ScrollArea="a1:f20"
29、新建工作簿
Set NewBook=Workbooks.AddNewBook.saveas "D:\大表格\新建.xls"NewBook.close
30、选择保存路径
fName=Application.GetSaveAsFilename '会打开保存对话框
if Fname<>"" then thisworkbook.saveas Fneme
31、打开文件、运行宏
Workbooks.Open "D:\大表格.XLS"
ActiveWorkbook.RunAutoMacros xlAutoOpen '有4个宏类型
32、获取当前工作簿路径
activecell=ActiveWorkbook.FullName '文件路径activecell=ActiveWorkbook.path '文件夹路径
33、关闭工作簿，并且放弃修改内容
Workbooks("BOOK1.XLS").CloseSaveChanges:=FalseActiveWorkbook.RejectAllChanges
34、隐藏图表
Charts(Array("Chart1","Chart3","Chart5")).Visible=False
35、禁止筛选（工作表将不能筛选）
'禁止筛选ActiveSheet.EnableAutoFilter = trueActiveSheet.Protect contents:=true, userInterfaceOnly:=true
'恢复筛选可用ActiveSheet.EnableAutoFilter = FalseActiveSheet.Protect contents:=False, userInterfaceOnly:=False
36、共享工作簿5分钟刷新一次
ActiveWorkbook.AutoUpdateFrequency=5
\
37、清空区域内容（不清空格式）
range("A1:D5").clearcontents '清空区域内容（不清空格式 和批注）range("A1:D5").clearcomments '清空区域批注（不清空格式 和内容）range("A1:D5").clear '清空区域内容、格式、批注
38、滚动条
Application.DisplayScrollBars=False '关闭滚动条
Application.DisplayScrollBars=true '开启滚动条
39、状态栏
Application.StatusBar = "大表格联系方式vx：1198061299" '状态栏显示信息
Application.StatusBar =false '关闭状态栏
40、隐藏工作表标签
ActiveWindow.DisplayWorkbookTabs = False '隐藏工作表标签ActiveWindow.DisplayWorkbookTabs = true '显示工作表标签
41、屏幕刷新
Application.ScreenUpdating = False '关闭屏幕刷新Application.ScreenUpdating = true '开启屏幕刷新
42、修改程序名称
Application.Caption = "大表格-管理系统"ActiveWindow.Caption = "大表格工作簿" '当前文件的名称
43、清空粘贴板
Application.CutCopyMode=false
44、获取程序信息
MsgBox "Excel 版本信息为:"& Application.CalculationVersionMsgBox "Excel 当前允许使用的内存为:"& Application.MemoryFreeMsgBox "Excel 当前已使用的内存为:"& Application.MemoryUsedMsgBox "Excel 可以使用的内存为:"& Application.MemoryTotalMsgBox "本机操作系统的名称和版本为:"& Application.OperatingSystemMsgBox "本产品所登记的组织名为:"& Application.OrganizationNameMsgBox "当前用户名为:"& Application.UserNameMsgBox "当前使用的 Excel 版本为:"& Application.VersionMsgBox "Excel启动的文件夹路径为：" & Chr(10) & Application.StartupPath
45、显示最近使用的文件并打开
MsgBox Application.RecentFiles(3).Name '最近第三个Application.RecentFiles(3).Open '打开
46、选择打开文件
With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = True '允许多选 .Show wb = .SelectedItems(1) '选中文件夹中的第一个文件路径 Workbooks.Open wb '打开文件End With
47、选择文件夹
With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = True .Show MyFile = .SelectedItems(1) '选中文件夹中的第一个文件夹路径End With
48、输入消息框
a = InputBox("请输入", "标题", "默认文本", 1) '消息框居中显示a = InputBox("请输入", "标题", "默认文本", 1,1) '消息框左上显示
'选择单元格消息框dim rng as range Set rng = Application.InputBox("请选择单元格", "标题", "默认文本", 50, 50, Type:=8) 'left=50 top=50 type:=8是单元格类型
type类型：0 公式1 数字2 文本（字符串）4 逻辑值（True 或 False）8 Range 对象形式的单元格引用16 错误值，如 #N/A64 数值数组
49、文件重命名
name "C:\上帝模式.txt" as "C:\上帝开挂模式.txt"
50、删除文件
Dim 文件$ 文件 = "C:\大表格.txt" If Dir(文件) <> "" Then Kill 文件 '存在该文件就删除
51、新建文件夹
sub 新建（） if dir("D:" & 文件夹名称)<>"" then msgbox "已存在该文件夹" else MkDir "D:" & 文件夹名称 msgbox "新建完成" end ifend sub
52、设置宏快捷键
sub 设置快捷键() Application.OnKey "%{q}", "宏名称" '按键alt + q 执行 宏end sub
53、删除重复值
sub 删除重复值（） ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNoend sub
54、获取工作表最后 行/列
sub 行列数（） a=cells(rows.count,1).end(xlup).row b=Cells(1, Columns.Count).End(xlToLeft).Column msgbox "最后一行是：" & a & chr(10) & "最后一列数：" & bend sub
55、向单元格输入信息
sub 输入信息() cells(1,1)="姓名：大表格" range("A2")="性别：男" [a3]="身份证号：4412241996********" '知道我很年轻就行了 range(cells(4,1),cells(4,1))=1000*10end sub
56、向单元格填充颜色，设置字体大小
sub 设置单元格颜色及字体（） range("A1").inteior.colorindex=25 '填充单元格颜色0-56 range("A1").font.colorindex=10 '设置字体颜色 range("A1").font.name="华文行楷" '设置字体 range("A1").font.size=12 '设置字体大小 Range("a1").RowHeight = 30 '设置行高 Range("a1").ColumnWidth = 30 '设置列宽 Range("a1").font.Underline = xlUnderlineStyleDouble '下划线 Range("a1").font.Italic = True '斜体 Range("a1").font.Bold = True '是否加粗end sub
57、打印设置
'大表格----------------------sub 打印设置（）With ActiveSheet.PageSetup .PrintTitleRows = "1:2" '工作表打印标题：顶端标题行(R) .PrintTitleColumns = "A:G" '工作表打印标题：左端标题列(C)End With
ActiveSheet.PageSetup.PrintArea = "A1:G100" '工作表打印区域(A)
With ActiveSheet.PageSetup .LeftHeader = "" '自定义页眉：左(L) .CenterHeader = "" '页眉/自定义页眉：中(C) .RightHeader = "" '自定义页眉：右(R) .LeftFooter = "" '自定义页脚：左(L) .CenterFooter = "" '页脚/自定义页脚：中(C) .RightFooter = "" '自定义页脚：右(R) .LeftMargin = Application.InchesToPoints(0.75) '页边距：左(L)_1.9厘米 .RightMargin = Application.InchesToPoints(0.75) '页边距：右(R)_1.9厘米 .TopMargin = Application.InchesToPoints(1) '页边距：上(T)_2.5厘米 .BottomMargin = Application.InchesToPoints(1) '页边距：下(B)_2.5厘米 .HeaderMargin = Application.InchesToPoints(0.5) '页边距：页眉(A)_1.3厘米 .FooterMargin = Application.InchesToPoints(0.5) '页边距：页脚(F)_1.3厘米 .PrintHeadings = False '工作表打印：行号列标(L) .PrintGridlines = False '工作表打印：网格线(G) .PrintComments = xlPrintNoComments '工作表打印批注(M)：无/(工作表末尾) xlPrintSheetEnd/(如同工作表中的显示) xlPrintIace .PrintQuality = 180 '页面打印质量(Q)：180/360点 英寸 .CenterHorizontally = False '页边距居中方式：水平(Z) .CenterVertically = False '页边距居中方式：垂直(V) .Orientation = xlPortrait '页面方向：纵向(T) xlPortrait/ 横向 (L)xlLandscape .Draft = False '工作表打印：按草稿方式(Q) .PaperSize = xlPaperA4 '页面纸张大小(Z)：A4 .FirstPageNumber = xlAutomatic '页面起始页码：自动 .Order = xlDownThenOver '工作表打印顺序：先列后行(D)/先行后列(V) xlOverThenDown .BlackAndWhite = False '工作表打印：单色打印(B) .Zoom = 100 '页面缩放比例：100% 若选择页面缩放比例，则下面两项没有。 .Zoom = False '页面缩放比例：未选择 若选择调整页面则此项必为False，且与下面两项一起出现。 .FitToPagesWide = 1 '页面缩放：调整为1页高 .FitToPagesTall = 1 '页面缩放：调整为1页宽 .PrintErrors = xlPrintErrorsDisplayed '工作表打印错误单元格打印为(E)：显示值/<空白> xlPrintErrorsBlank/-- xlPrintErrorsDash/#N/A xlPrintErrorsNAEnd Withend sub
58、批量插入图片
Sub test()Dim i As IntegerFor i = 3 To 5 'Sheets("表名称").Shapes.AddPicture "图片路径",msoFalse, msoCTrue, 离左,离高，宽，高度 Sheets(i).Shapes.AddPicture "D:\名称" & i & ".png", msoFalse, msoCTrue, Range("C7:E11").Left, Range("C7:E11").Top, Range("C7:E11").Width, Range("C7:E11").HeightNextMsgBox "插入完毕"End Sub
59、连接数据库
Private Sub Command1_Click()
On Error GoTo err '忽略错误Dim cnn As ADODB.Connection '接口Dim rst As ADODB.Recordset '数据集Dim rst1 As ADODB.RecordsetDim mysql As String
Set rst = New ADODB.Recordset 新数据集Set rst1 = New ADODB.RecordsetSet cnn = New ADODB.Connection
'数据库mydata = "C:\Users\Administrator\Desktop\南海销售明细.accdb"
'SQL语句mysql = "select 登录名 from 用户" '查找有没有该用户mysql1 = "select 登录密码 from 用户"
'打开链接数据库With cnn .Provider = "Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password='123456'" .Open mydataEnd With
'获取语句记录集rst.Open mysql, cnn
For i = 1 To rst.Fields.Count '遍历数据集 s = s & rst.Fields(i - 1).ValueNext
rst1.Open mysql1, cnn '以记录集方式打开 执行语句For i = 1 To rst1.Fields.Count y = y & rst1.Fields(i - 1).ValueNextText6 = sText7 = yExit Suberr: MsgBox "err"End Sub
60、隐藏筛选箭头
'跟上面的禁止筛选不一样，这里仅是隐藏箭头，可以筛选Range("A1").AutoFilter Field:=1,VisibleDropDown:=False '隐藏筛选的第一列的筛选箭头Range("A1").AutoFilter Field:=2,VisibleDropDown:=False '隐藏第二列箭头
\
61、筛选
If ActiveSheet.AutoFilterMode = False Then '如果没打开筛选 ActiveSheet.AutoFilterMode = True '打开 Range("A1").AutoFilter '筛选End If
Range("A1").AutoFilter Field:=2,Criteria1:="=男" '筛选的第二列，条件=男Range("A1").AutoFilter Field:=3,Criteria1:=">=80"
Range("A1:F" &lngLastRow).Copy Range("H21") 'vba的复制只复制可见单元格，所以可以将筛选结果复制
\
62、禁止触发别的事件
Application.EnableEvents = False '防止执行代码触发别的事件Application.EnableEvents = true
63、新建工具栏功能按钮
On Error Resume Next CommandBars("编码").Delete '工具栏名称 With CommandBars.Add("编码", msoBarTop, , True) '新建按钮 .Visible = True '显示按钮 With .Controls.Add '新建工具栏 .FaceId = 263 '设置图标样式 .TooltipText = "我" .OnAction = "宏1" '调用宏名 .Caption = "大表格(&Q)" '设置名称 和 快捷键 .Style = msoButtonIconAndCaption .Enabled = False '设置按钮是否可用 '.SetFocus '获取焦点 End With End With
64、将所有按钮样式插入到工具栏
'直接运行即可（花时间一分钟左右）Dim NewToolbar As CommandBar Dim NewButton As CommandBarButton Dim i As Integer, IDStart As Integer, IDStop As Integer
' Delete existing FaceIds toolbar if it exists On Error Resume Next Application.CommandBars("FaceIds").Delete On Error GoTo 0
' Add an empty toolbar Set NewToolbar = Application.CommandBars.Add _ (Name:="FaceIds", temporary:=True) NewToolbar.Visible = True
' Change the following values to see different FaceIDs IDStart = 1 IDStop = 800
For i = IDStart To IDStop Set NewButton = NewToolbar.Controls.Add _ (Type:=msoControlButton, ID:=2950) NewButton.FaceId = i NewButton.Caption = "FaceID = " & i Next i NewToolbar.Width = 600
65、破解VBA工程密码
1、先打开要破解的VBA工程文件
2、新建一个工作簿（将下面代码复制到 《新建工作簿》的模块里）
3、在新建工作簿的宏运行 《破解》\
4、在VBA工程界面--找到要破解的 工程 双击进去）
是不是如入无人之境----------哈哈哈\
Option ExplicitPrivate Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _(Destination As Long, Source As Long, ByVal Length As Long)Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As LongPrivate Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As LongPrivate Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _ByVal lpProcName As String) As LongPrivate Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByValhInstance As Long, _ByVal pTemplateName As Long, ByVal hWndParent As Long, _ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As IntegerDim HookBytes(0 To 5) As ByteDim OriginBytes(0 To 5) As ByteDim pFunc As LongDim Flag As Boolean
Private Function GetPtr(ByVal Value As Long) As Long '获得函数的地址 GetPtr = Value End Function Public Sub RecoverBytes() '若已经 hook,则恢复原 API 开头的 6 字节,也就是恢复原来函数的功能 If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6 End SubPublic Function Hook() As Boolean Dim TmpBytes(0 To 5) As Byte Dim p As Long Dim OriginProtect As Long Hook = False
'VBE6.dll 调用 DialogBoxParamA 显示 VB6INTL.dll 资源中的第 4070 号对话框(就是输入密码的 窗口) '若 DialogBoxParamA 返回值非 0,则 VBE 会认为密码正确,所以我们要 hook DialogBoxParamA函数 pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")'标准 api hook过程之一: 修改内存属性,使其可写 If VirtualProtect(ByVal pFunc, 6, &H40, OriginProtect) <> 0 Then '标准 api hook过程之二: 判断是否已经 hook,看看 API 的第一个字节是否为&H68, '若是则说明已经 Hook MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6 If TmpBytes(0) <> &H68 Then '标准 api hook过程之三: 保存原函数开头字节,这里是 6 个字节,以备后面恢复 MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6 '用 AddressOf 获取 MyDialogBoxParam 的地址 '因为语法不允许写成 p = AddressOf MyDialogBoxParam这, 里我们写一个函数 'GetPtr,作用仅仅是返回 AddressOf MyDialogBoxParam的值,从而实现将 'MyDialogBoxParam 的地址付给 p 的目的 p = GetPtr(AddressOf MyDialogBoxParam) '标准 api hook过程之四: 组装 API 入口的新代码 'HookBytes 组成如下汇编 'push MyDialogBoxParam的地址 'ret '作用是跳转到 MyDialogBoxParam 函数 HookBytes(0) = &H68 MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4 HookBytes(5) = &HC3 '标准 api hook过程之五: 用 HookBytes 的内容改写 API 前 6 个字节 MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6 '设置 hook 成功标志 Flag = True Hook = True End If End IfEnd FunctionPrivate Function MyDialogBoxParam(ByVal hInstance As Long, _ByVal pTemplateName As Long, ByVal hWndParent As Long, _ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As IntegerIf pTemplateName = 4070 Then '有程序调用 DialogBoxParamA 装入 4070 号对话框,这里我们直接返回 1,让 'VBE 以为密码正确了 MyDialogBoxParam = 1 Else '有程序调用 DialogBoxParamA,但装入的不是 4070 号对话框,这里我们调用 'RecoverBytes 函数恢复原来函数的功能,在进行原来的函数 RecoverBytes MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _ hWndParent, lpDialogFunc, dwInitParam) '原来的函数执行完毕,再次 hook Hook End IfEnd Function
Sub 破解() If Hook Then 'Hook 是破解过程 MsgBox " 破解成功 " End IfEnd Sub
Sub 恢复()RecoverBytesMsgBox " 恢复成功 "End Sub
\
66、破解工作表保护密码
Private Sub CommandButton1_Click() '破解'运行破解Call AllInternalPasswordsEnd Sub
'将下列代码复制到要破解的工作表的 一个代码里Public Sub AllInternalPasswords()' Breaks worksheet and workbook structure passwords. Bob McCormick' probably originator of base code algorithm modified for coverage' of workbook structure / windows passwords and for multiple passwords'' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)' Modified 2003-Apr-04 by JEM: All msgs to constants, and' eliminate one Exit Sub (Version 1.1.1)' Reveals hashed passwords NOT original passwordsConst DBLSPACE As String = vbNewLine & vbNewLineConst AUTHORS As String = DBLSPACE & vbNewLine & _"Adapted from Bob McCormick base code by" & _"Norman Harker and JE McGimpsey"Const HEADER As String = "AllInternalPasswords User Message"Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"Const REPBACK As String = DBLSPACE & "Please report failure " & _"to the microsoft.public.excel.programming newsgroup."Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _"now be free of all password protection, so make sure you:" & _DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _DBLSPACE & "Also, remember that the password was " & _"put there for a reason. Don't stuff up crucial formulas " & _"or data." & DBLSPACE & "Access and use of some data " & _"may be an offense. If in doubt, don't."Const MSGNOPWORDS1 As String = "There were no passwords on " & _"sheets, or workbook structure or windows." & AUTHORS & VERSIONConst MSGNOPWORDS2 As String = "There was no protection to " & _"workbook structure or windows." & DBLSPACE & _"Proceeding to unprotect sheets." & AUTHORS & VERSIONConst MSGTAKETIME As String = "After pressing OK button this " & _"will take some time." & DBLSPACE & "Amount of time " & _"depends on how many different passwords, the " & _"passwords, and your computer's specification." & DBLSPACE & _"Just be patient! Make me a coffee!" & AUTHORS & VERSIONConst MSGPWORDFOUND1 As String = "You had a Worksheet " & _"Structure or Windows Password set." & DBLSPACE & _"The password found was: " & DBLSPACE & "" & DBLSPACE & _"Note it down for potential future use in other workbooks by " & _"the same person who set this password." & DBLSPACE & _"Now to check and clear other passwords." & AUTHORS & VERSIONConst MSGPWORDFOUND2 As String = "You had a Worksheet " & _"password set." & DBLSPACE & "The password found was: " & _DBLSPACE & "" & DBLSPACE & "Note it down for potential " & _"future use in other workbooks by same person who " & _"set this password." & DBLSPACE & "Now to check and clear " & _"other passwords." & AUTHORS & VERSIONConst MSGONLYONE As String = "Only structure / windows " & _"protected with the password that was just found." & _ALLCLEAR & AUTHORS & VERSION & REPBACKDim w1 As Worksheet, w2 As WorksheetDim i As Integer, j As Integer, k As Integer, l As IntegerDim m As Integer, n As Integer, i1 As Integer, i2 As IntegerDim i3 As Integer, i4 As Integer, i5 As Integer, i6 As IntegerDim PWord1 As StringDim ShTag As Boolean, WinTag As Boolean
Application.ScreenUpdating = FalseWith ActiveWorkbookWinTag = .ProtectStructure Or .ProtectWindowsEnd WithShTag = FalseFor Each w1 In WorksheetsShTag = ShTag Or w1.ProtectContentsNext w1If Not ShTag And Not WinTag ThenMsgBox MSGNOPWORDS1, vbInformation, HEADERExit SubEnd IfMsgBox MSGTAKETIME, vbInformation, HEADERIf Not WinTag ThenMsgBox MSGNOPWORDS2, vbInformation, HEADERElseOn Error Resume NextDo 'dummy do loopFor i = 65 To 66: For j = 65 To 66: For k = 65 To 66For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126With ActiveWorkbook.Unprotect Chr(i) & Chr(j) & Chr(k) & _Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)If .ProtectStructure = False And _.ProtectWindows = False ThenPWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)MsgBox Application.Substitute(MSGPWORDFOUND1, _"", PWord1), vbInformation, HEADERExit Do 'Bypass all for...nextsEnd IfEnd WithNext: Next: Next: Next: Next: NextNext: Next: Next: Next: Next: NextLoop Until TrueOn Error GoTo 0End IfIf WinTag And Not ShTag ThenMsgBox MSGONLYONE, vbInformation, HEADERExit SubEnd IfOn Error Resume NextFor Each w1 In Worksheets'Attempt clearance with PWord1w1.Unprotect PWord1Next w1On Error GoTo 0ShTag = FalseFor Each w1 In Worksheets'Checks for all clear ShTag triggered to 1 if not.ShTag = ShTag Or w1.ProtectContentsNext w1If ShTag ThenFor Each w1 In WorksheetsWith w1If .ProtectContents ThenOn Error Resume NextDo 'Dummy do loopFor i = 65 To 66: For j = 65 To 66: For k = 65 To 66For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126.Unprotect Chr(i) & Chr(j) & Chr(k) & _Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)If Not .ProtectContents ThenPWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)MsgBox Application.Substitute(MSGPWORDFOUND2, _"", PWord1), vbInformation, HEADER'leverage finding Pword by trying on other sheetsFor Each w2 In Worksheetsw2.Unprotect PWord1Next w2Exit Do 'Bypass all for...nextsEnd IfNext: Next: Next: Next: Next: NextNext: Next: Next: Next: Next: NextLoop Until TrueOn Error GoTo 0End IfEnd WithNext w1End IfMsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADEREnd Sub
67、批量获取图片文件名
'批量提取文件名Dim mypath As String, n%, myfile As String '定义变量
'文件夹选择器With Application.FileDialog(msoFileDialogFolderPicker) .Title = "选择文件夹" '窗口标题 If .Show Then '如果有选择文件夹 ipath = .SelectedItems(1) '文件夹路径 End IfEnd With mypath = ipath & "" '文件/夹所在路径 n = 1 myfile = Dir(mypath & "*.*") '提取文件路径中的所有文件，此时返回第一个文件的名字 可以筛选*.xls *.jpg Do While myfile <> "" '当文件名不为空时，循环提取文件名 Cells(n, 1) = myfile n = n + 1 myfile = Dir Loop
68、批量插入图片
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "选择文件夹" If .Show Then ipath = .SelectedItems(1) End If
If ipath = "false" Or Len(ipath) = 0 Then MsgBox "请选择正确的文件夹路径" Exit Sub End IfEnd With
插入列数 = VBA.Val(InputBox("请输入插入图片列数")) + 1
'以下代码是根据名称插入图片Dim fs, myfold, myfile, k
Set fs = CreateObject("scripting.filesystemobject")'Print ''建立文件系统对象变量fs
Set myfold = fs.getfolder(ipath)''使用GetFolder方法获取文件夹的信息
Set myfile = myfold.Files''使用Files属性获取文件夹下所有文件集合 For Each k In myfile '循环文件集合中的文件 With ActiveSheet '注意改工作表 If k <> "" Then n = VBA.Int(Range("A:A").Find(k.Name).Row / 插入列数) + 1 '只是用来找图片的行数 好把图片放在对应的行 ，有效数就下一行 If (Range("A:A").Find(k.Name).Row Mod 插入列数) = 0 Then nn = (Range("A:A").Find(k.Name).Row Mod 插入列数) + 2 '列数 因为刚好4的倍数时，0列 要从第二列开始 ，所以加2 Else nn = (Range("A:A").Find(k.Name).Row Mod 插入列数) + 1 '列数 End If .Shapes.AddPicture k, False, True, Cells(n, nn).Left, .Cells(n, nn).Top, .Cells(n, nn).Width, .Cells(n, nn).Height End If End With Next
69、删除图片
Dim p As Shape For Each p In ActiveSheet.Shapes If p.Type = 13 Then p.Delete End If Next
70、快捷键
按键 功能ctrl+9 隐藏选择行ctrl+0 隐藏选择列shift+空格 选中整行shift+F2 插入并编辑批注（不改变内容）ctrl+home 回到工作表第一个单元格ctrl+end 回到工作表最后一个单元格shift+tab 向左换列ctrl+tab 切换工作簿ctrl+F3 定义名称alt+= 求和ctrl+; 2018/11/11 输入当前日期ctrl+shift+; 13:26:00 输入当前时间先按ctrl+； 再按ctrl+shift+； 2018/11/11 13:26ctrl+K 插入超链接ctrl+shift+” 将上一个单元格的数值复制到选中单元格（活动单元格）720 ctrl+1 设置单元格格式ctrl+2 设置字体粗体ctrl+3 设置字体斜体ctrl+4 设置下划线ctrl+5 设置删除线
\
需要视频教程的VX：1198061299 大表格
