|
1、 常用单句 常用调试工具 Debug.Print；MsgBox；立即窗口，本地窗口，监视窗口 常用开头与结尾 Dim tim As Date: tim = Timer '记录当前时间(0到开始到现在的时间,单位为秒) Application.ScreenUpdating = False '关闭屏幕更新 Application.DisplayAlerts = False '关闭提示 Call 调用程序 MsgBox Format(Timer - tim, '程序执行时间为：0.00秒'), 64, '时间统计' '报告代码的执行时长 Application.ScreenUpdating = True '恢复屏幕更新 Application.DisplayAlerts = True '恢复提示 清除内容和添加边框 .ClearContents '删除当前区域值 .Borders.LineStyle = 0 '删除当前区域边框 .Borders.LineStyle = 1 '当前区域添加边框 Error语句 On Error Resume Next '当程序出错时继续执行下一句 Err.Clear'清除错误值 常用变量类型及简码 Dim Ows As Worksheet, Orng As Range ,Dic1 As Object；Private ；Public integer % 短整型-32,768 到 32,767 long &长整型-2,147,483,648 ---- 2,147,483,648贰拾亿 single !单精度浮点型 string $ 字符型 字典常用 Set Dic1 = CreateObject('scripting.dictionary') '创建字典对象，并赋值给Dic1 Dic1.Item(Arr (i, 2)) = Dic1.Item(Arr (i, 2)) + Arr (i, 1) '汇总求和 字典对象的方法有6个：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。 Exists方法：object.Exists(key) Remove方法：object.Remove(key ) RemoveAll方法：object.RemoveAll CStr(expression) - 转换为String型'字典中的key属性尽量用String型 移出字典中特定的项目 For Each K1 In Dic2.KEYs '循环字典的KEYS If Dic2.Item(K1) >= 0 Then Dic2.Remove (K1) ' 移出item大于或等于零的项目 Next For Each K1 In Arr临2 '循环数组中的值 If Dic2.Exists(K1) = True Then Dic2.Remove (K1) '如果字典中存在，移出字典 Next 数组常用 Option Base 1'数组下标为'1' Cr= Cr+1；ReDim Preserve Arr2(1 To 2, 1 To Cr)'最后一维可以变化，不清除原数组的值 Arr1 = [{'仓库收发存汇总报表','库存原表';'材料在制明细报表','在制原表'}]'二维数组赋值 UBound(Arr1, 1)'数组上标 Join - 连接数组成字符串。 Split - 拆分字符串成数组。 常用判断条件 If InStr('-0-J-', '-' & Left(Arr原(Item, 1), 1) & '-') > 0 Then '取成品码 Set Orng = Ows.UsedRange.Find(关键字) '返回Range对象 If Not Orng Is Nothing Then'如果不是空值 单元格引用 Range('A1')；Range('A1:F10000')；Range('2:2')；Range('D:d') Rows(2)；Rows('2') ；Rows('2:2')； Columns(2) ；Columns('B') ；Columns('B:B') ； Cells(5,4)；Cells(12, 'ZZ')；Cells('12', 'ZZ')；Range('B2:G10').Cells(5)； [a1] ；[B$10] ；也表示偏移，通常不用这个功能。 [D2:F500] ——表示引用D2:F500区域，包括1497个单元格 [D2,F2] ——表示引用D2和F2两个单元格 [D2:D3,F2:G10,Z100] ——表示引用D2:D3和F2:G10、Z100三个区域，包括21个单元格 .Offset(0, 2).Resize(Dic1.Count, 1) = Application.WorksheetFunction.Transpose(Dic1.items) '写入数量 arr = Sheets('原始数据').[a1].CurrentRegion'A1单元格+Ctrl+A Resize(.UsedRange.Rows.Count, 4).ClearContents '清除前期内容 .Cells(.Rows.Count, 18).End(xlUp).Row'最后一行行数 .Sheets.Add(, .Sheets(.Sheets.Count)).Name = Arr1(j, 2) '在最后一个工作表后新建工作表 2、常用案例 提取文件 思路：用Application.GetOpenFilename把工作簿读入Filename数组中，逐个工作簿循环，逐个工作表循环，逐个关键字循环。用find判断查找关键字，确定需要的文件。提取文件后在Old_Name的工作簿中建工作表，把查找到的工作表复制过去。 Sub 提取文件() On Error Resume Next '当程序出错时继续执行下一句 Dim Arr1(), i %, j %, Ows As Worksheet, Orng As Range, Arr1(),Filename, _ Old_Name$, New_Name$ '声明变量，由于GetOpenFilename的返回值是数组，变量只能用变体型 Arr1 = [{'仓库收发存汇总报表','库存原表';'材料在制明细报表','在制原表'}] Old_Name = ActiveWorkbook.Name '获取当前工作簿的名称 '创建一个打开文件的对话框，允许多选，然后将返回值赋予变量FileName Filename = Application.GetOpenFilename('文本文件,*.txt;*.xls?', , '请选择文本文件', , True) For i = 1 To UBound(Filename) '遍历数组,Ubound函数用于计算数组中的数据个数 If Err.Number> 0 Then Exit Sub '如果有错误，那么结束过程(单击了'取消'键时才会有错误) Workbooks.Open Filename(i) '逐一报告数组中的文件名称 New_Name = ActiveWorkbook.Name For j = 1 To UBound(Arr1, 1) For Each Ows In Workbooks(New_Name).Worksheets With Ows.UsedRange Set Orng = .Find(Arr1(j, 1)) '返回Range对象 If Not Orng Is Nothing Then With Workbooks(Old_Name) .Sheets(Arr1(j, 2)).Delete: Err.Clear '删除工作表'清除错误值， '避免'i=2时Err.Number> 0直接退出程序 .Sheets.Add(, .Sheets(.Sheets.Count)).Name = Arr1(j, 2) '在最后一个工作表后新建工作表 End With .Copy Workbooks(Old_Name).Sheets(Arr1(j, 2)).Cells(1) '复制工作表 Exit For End If End With Next Ows Next j ActiveWorkbook.Close , False '关闭工作簿 Next i End Sub 保存文件Sheets.Copy Sub 保存工作报表() 思路：用Application.FileDialog(msoFileDialogFolderPicker)选择路径，用Path记录路径 Dim ShtDate,Path$ '声明变量 ActiveWorkbook.Save ShtDate = Format(Date, 'yyyy-mm-dd') '将今日日期格式化为'yyyy-mm-dd'格式 With Application.FileDialog(msoFileDialogFolderPicker) '弹出对话框让用户选择路径 If .Show = -1 Then '如果选择了文件夹则 Path = .SelectedItems(1) &IIf(Right(.SelectedItems(1), 1) = '\', '', '\')'记录路径 Else Exit Sub End If End With Sheets.Copy '复制所有工作表 Sheets('功能区').Delete '删除带控件的工作表 ActiveWorkbook.SaveAs Path & 'M1资源结构分析表' &ShtDate, xlWorkbookDefault ActiveWorkbook.Close , False '关闭工作簿 End Sub 常用函数 注意很多excel函数的参数是range，而不是arry, Sumifs用法 思路:定义range对象，通过Application.WorksheetFunction.引用函数SumIfs Set Orng编码列 = .Range('H5:H' & R原) Set Orng状态列 = .Range('E5:E' & R原) Set Orng完工数 = .Range('N5:N' & R原) With Sheets('完工取数') For i = 0 To UBound(Arr编码) For j = 1 To UBound(Arr在制, 2) Arr在制(i, j) = Application.WorksheetFunction.SumIfs(.Range('W5:W' & R原).Offset(, j - 1), Orng编码列, Arr编码(i), Orng状态列, '已关闭') _ + Application.WorksheetFunction.SumIfs(.Range('W5:W' & R原).Offset(, j - 1), Orng编码列, Arr编码(i), Orng状态列, '完成') Next Next End With 其他常用函数 Abs绝对值函数 字典Exists判断汇总1 Set Dic1 = CreateObject('scripting.dictionary') '创建字典对象，并赋值给Dic1 Set Dic2 = CreateObject('scripting.dictionary') '创建字典对象，并赋值给Dic2 Arr1 = .Range('A2').Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 1, 4).Value '将所有数据写入数组 For i = 1 To UBound(Arr1, 1) '遍历数据 '取商品名称与价格 If Dic1.Exists(Arr1(i, 1) & Arr1(i, 2)) = False Then'如果字典中没有key则 j = j + 1 ReDim Preserve Arr2(1 To 2, 1 To j)'数组增加一列，最终数据增加一行 Arr2(1, j) = Arr1(i, 1): Arr2(2, j) = Arr1(i, 2) End If Dic1.Item(Arr1(i, 1) & Arr1(i, 2)) = Dic1.Item(Arr1(i, 1) & Arr1(i, 2)) + Arr1(i, 3) '取数量 Dic2.Item(Arr1(i, 1) & Arr1(i, 2)) = Dic2.Item(Arr1(i, 1) & Arr1(i, 2)) + Arr1(i, 4) '取金额 Next With .Range('G2') .Resize(UBound(Arr2, 2), 2) = Application.WorksheetFunction.Transpose(Arr2) '写入商品名称与单价 .Offset(0, 2).Resize(Dic1.Count, 1) = Application.WorksheetFunction.Transpose(Dic1.items) '写入数量 .Offset(0, 3).Resize(Dic2.Count, 1) = Application.WorksheetFunction.Transpose(Dic2.items) '写入金额 End With 3、非常用案例 使用期限设置 思路：打开工作簿时给'期限'和当前日期赋值，并提醒报表使用者，关闭工作簿时（Kill .FullName）删除。注意：删除后数据无法恢复。 Private a$, 期限$ '定义共用变脸 Sub Auto_open() '打开工作簿时执行 期限 = '2018年2月27日' a = Format(Date, 'yyyy年m月d日') '当前年月日 If a >期限 Then MsgBox '超过使用期限；' &Chr(13) _ & '工作簿将自动删除；' &Chr(13) _ & '请复制要保存的数据' End Sub 'Sub Auto_close() '打开工作簿时执行 If a >期限 Then With ThisWorkbook '引用ThisWorkbook .Saved = True '标识为已保存状态 .ChangeFileAccess Mode:=xlReadOnly '设为只读模式 Kill .FullName '删除ThisWorkbook .Close '关闭ThisWorkbook End With End If End Sub 建立超链接工作表目录Hyperlinks Sub 建立工作表目录() Dim Sht As Worksheet, i As Integer '声明一个对象变量一个Integer变量 For Each Sht In Sheets '遍历所有表 '如果sht的名字等于'工作表目录'，那么跳转至标签Mulu处 If Sht.Name = '工作表目录' Then GoToMulu Next Worksheets.Add Worksheets(1) '新建一个工作表，将它放在第一个工作之前 ActiveSheet.Name = '工作表目录' '将活动工作表命名为'工作表目录' Mulu: '设置一个名为'Mulu'的标签 Worksheets('工作表目录').Range('A:B').Clear '清除A、B两列的值 For Each Sht In Worksheets '遍历所有工作表 If Sht.Name<> '工作表目录' Then '如果sht的名称不等于'工作表目录' i = i + 1 '累加计数器 Worksheets('工作表目录').Cells(i, 1).Value = i '在A列输入编号 '在B列创建超级链接,从而允许单击单元格时进入相应的工作表 Worksheets('工作表目录').Hyperlinks.Add Anchor:=Worksheets('工作表目录').Cells(i, 2), Address:='', SubAddress:=''' &Sht.Name& ''!A1', TextToDisplay:=Sht.Name, ScreenTip:='单击打开：' &Sht.Name End If Next End Sub Rem Hyperlinks.Add方法用于创建超级链接，其语法如下： Rem Hyperlinks.Add(Anchor, Address, SubAddress, ScreenTip, TextToDisplay) Rem 各参数的含义如下: Rem 名称必选/可选数据类型说明 Rem Anchor 必选 Object 超链接的位置。可为 Range 或 Shape 对象。 Rem Address 必选 String 超链接的地址。 Rem SubAddress可选 Variant 超链接的子地址。 Rem ScreenTip 可选 Variant 当鼠标指针停留在超链接上时所显示的屏幕提示。 Rem TextToDisplay可选 Variant 要显示的超链接的文本。 Inputbox用法 注意：inputbox只能调用本工作簿中的区域，需增加其他语句配合调用其他工作簿。 粘贴时跳过隐藏行 思路：用inputbox选择区域，然后Rng选取可见区域，循环可见区域单元格，逐一赋值 Sub 粘贴时跳过隐藏行() On Error Resume Next '当程序出错时继续执行下一句 Dim Rng As Range, i%, C As Range, 复制 As Range, 粘贴 As Range, Arr() Set 复制 = Application.InputBox(prompt:='请选择要复制的区域', Type:=8) If 复制 Is Nothing Then Exit Sub '如果没有赋值，退出程序 Set 粘贴 = Application.InputBox(prompt:='请选择要粘贴的区域', Type:=8) If 粘贴 Is Nothing Then Exit Sub '如果没有赋值，退出程序 Set Rng = 粘贴.SpecialCells(xlCellTypeVisible) '将选择区域可见的部分赋值给rng Arr = 复制.Value '将复制的数据赋值给数组 For Each C In Rng '逐一选取可见的单元格 i = i + 1 C.Value = Arr(i, 1) '将复制的内容逐一粘贴到目标区域 If i = UBound(Arr, 1) Then Exit For '如果复制的值结束，退出循环。（本句避免复制的区域低于粘贴区域时出错） Next End Sub |
|
|
