2022年编程常用代码 .pdf

《2022年编程常用代码 .pdf》由会员分享，可在线阅读，更多相关《2022年编程常用代码 .pdf（13页珍藏版）》请在淘文阁 - 分享文档赚钱的网站上搜索。

1、编程常用代码Excel2007 启用宏： OFFICE 按钮选项信任中心信任中心设置宏设置代码里可以 命名名称 ，比如rng1.Name = data1 ，然后在公式中使用它Debug.Print 7777 在立即窗口中显示Environ(Computername) 计算机名Environ(userprofile)桌面路径ActiveWindow.Caption=XXXXX 在显示文件名的地方显示XXXXX Windows(ThisWorkbook.Name).Visible = False 隐藏 excel 主窗口 ThisWorkbook.Name 文件名 - 文件和文件夹当前文件夹的名称

2、：CurDir 更改文件或文件夹的名称：（Name 原文件As 新文件）检查文件或文件夹是否存在：m=Dir(文件 ,Nomal) m=Dir(文件夹 ,Folder)Directory 创建文件夹 （MkDir D：文件夹名 ）省份分表 , vbDirectory) 判断是否已经存在省份分表 ) 如果不存在就建立删除文件：（Kill D： 文件夹名成品 .xls 删除空文夹：（RmDir D： 文件夹名 ）- 复制文件：（FileCopy）For i = 101 To 10000 迅雷文件夹名 & i & 迅雷 .txt Next With Application.FileSearch .F

3、ilename = *.* 分表 .Execute k = .FoundFiles.Count 文件夹中的文件个数End With Sub 生成目录 () 有子文件夹也查到Set fs = Application.FileSearch With fs 暂用 设置要查找的起始目录.Filename = *.* .SearchSubFolders = True 是否查找子目录.Execute 根据上面的设置执行查找For i = 1 To .FoundFiles.Count 遍历文件a = Dir(.FoundFiles(i) Cells(i + 1, 3) = a Next i End With

4、 End Sub 生成的表 , vbMaximizedFocus展开文件夹Sub 动态读取指定文件夹名() On Error Resume Next Dim stMedd As String stMedd = 请选择文件目录： Set obMapp = CreateObject(Shell.Application).BrowseForFolder(0, stMedd, &H1) If Not obMapp Is Nothing Then 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第

5、 1 页，共 13 页 - - - - - - - - - Directory = obMapp.self.Path & 文件夹名G1.Value = Directory Else Exit Sub End If Call FilesList.FilesList End Sub 变量模块级变量的声明格式Public Directory Dim x As Integer 声明变量Byte (0 到 255 的整数 ) Integer % (-32768+32768) Date ( 日期 ) String $ (65400 个字符 ) Decimal ( 小数 ) Long & Single !

6、Currency Format(32, 0000) Format 格式 结果为： 0032 Dim Arr() 数组ReDim Preserve Arr(1 To r) 声明动态数组Array 函数Application.Transpose 转置数组下限LBound(Arr)=0 ，数组上限UBound(Arr)=4 Erase arr 清空数组IsArray 指出变量是否为一个数组If Application.CountA(Arr)0 Then 判断数组不为空Range(A1:D1) = Array(1001, 现金 , 300000, Date) 在一 行多列中依次输入不同数据Range(

7、A1:A4) = Application.Transpose(Array(1001, 现金 , 300000, Date) 在一 列多行中次输入不同数Sub 字典() r = Sheet1.Range(A65536).End(xlUp).Row 最后行数Set w = CreateObject(scripting.dictionary) For i = 2 To r b = Sheet1.Cells(i, 2) c = Sheet1.Cells(i, 3) If Not w.exists(b & c) Then w(b & c) = 1 Else W(b & c) = W(b & c) + 1

8、 End If Next A2.Resize(w.Count, 1) = Application.Transpose(w.keys) B2.Resize(w.Count, 1) = Application.Transpose(w.items) End Sub Sub 用字典筛选多列() r = Range(A65536).End(xlUp).Row 最后行数名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 2 页，共 13 页 - - - - - - - - - Set w = Cre

9、ateObject(scripting.dictionary) For i = 2 To r If Cells(i, 6) 70 Then 语文分数为条件w(Range(Cells(i, 1), Cells(i, 12) = 1 数据一行多列载入字典End If Next i N2.Resize(w.Count, 12) = Application.Transpose(Application.Transpose(w.keys) 两次转置写入单元格End Sub If dfgLike *f* Then判断字符串包含关系可用通配符For Each st In Worksheets With Chr

10、(10) Exit For step 步长 ElseIf Else Do While Loop Application.ScreenUpdating = False 禁用刷新Application.DisplayStatusBar = False 禁用状态显示Application.Calculation = xlCalculationManual 手动重算Application.EnableEvents = False 禁用触发事件ActiveSheet.DisplayPageBreaks = False 禁用新版本Application.ScreenUpdating = true 启用刷新

11、Application.DisplayStatusBar = true 显示状态Application.EnableEvents = true 启用触发事件Application.Calculation = xlAutomatic 自动重算ActiveSheet.DisplayPageBreaks = true 启用新版本Application.SheetsInNewWorkbook = 1设置工作簿内的工作表数Application.SendKeys %down 自动打开数据有效性列表Workbooks(学习 .xls). Worksheets(Sheet1).Range(A4).Clear

12、Contents 从文件到单元格Cells(4, 1) Rang(A4) A4 单元格Range(H3).Select 选定单元格Range(A65536).End(xlUp) 最后行单元数据x=Range(A65536).End(xlUp).Row 行数x = Range(e2).End(xlDown).Row 向下查找Range(IV1).End(xlToLeft) 最后列单元数据Range(IV1).End(xlToLeft).Column 列数UsedRange.Cells 工作表使用区域的单元格a = ActiveSheet.UsedRange.Item(ActiveSheet.Us

13、edRange.Count).Row 格式 最后行b = ActiveSheet.UsedRange.Item(ActiveSheet.UsedRange.Count).Column 格式 最后列Cells(a, b) 最后一个单元格（不一定有数据）(Cells(1, 1), Cells(a, b) 数据最大区间起于A1 单元格，止于最右下角单元格f= Replace(mid(Cells(100,103).Address,2,2),$,) 由列数得到列标CY Cells.Find(*, , , , , 2).Row 工作表使用的有数据行数Cells.Find(*, , , , , 2) .Co

14、lumn 工作表使用的有数据列数IsNumeric 判断数值名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 3 页，共 13 页 - - - - - - - - - Sheet1.UsedRange.Select 选定表 1 中使用的区域 ，如果要向下或右移在UsedRange.后加进 offset(1,2) Range(a1).Copy Range(B1) 将 A1 单元数值（公式）和格式值复制到sheet3 B1 中注： Range(a1)不能用 Cells()替代Range(B

15、1).Value = Range(a1).Value 将 A1 单元数值复制到sheet3 B1 中Range(C4:E7).Clear 清除格式和内容Range(D4:E6).ClearContents 清除内容ActiveWindow.VisibleRange.AddressLocal 返回屏幕上可以看到的区域a3.Value = Trim(a3.Value) 删除空格删 左边 Ltrim 删右边 RTrima:a.Replace A, 将 A 列的“ A”替换成空单元格匹配LookAt:=xlWhole Application.SUBSTITUTE(A1, ,) 清除空格Range(B2

16、).Offset(1, 2).Select 以 B2 为基点，向下移1 行，向右移 2 列Selection.Resize(6, 9).Select 得到一个6行 9 列的区域Range(S1:S28).TextToColumns DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(2, 1) 只分出第1、2 个字符Range(B3:B & k.Count + 2).TextToColumns , Other:=True, OtherChar:=/ 分列a:b.AdvancedFilter 2, c1:c2, g1 高级筛选最

17、简代码数据区间 a:b 条件 c1:c2 存放位置 g1 Sheet1.a:a.AdvancedFilter 2, , b5, Unique:=True Unique:=True (取不重复值 ) A1:D11.AdvancedFilter 2, , E1, 1 高级筛提取 不重复值 数据区间 A1:D11 存放位置 E1MsgBox 行数为： & ActiveCell.Row & Chr(10) & 列数为： & ActiveCell.Column当前行列数Chr(10) ：空行公式ClearContents仅清除单元格或单元格区域内的数据ClearFormats仅清除格式Range(A1)

18、.NumberFormat 读出 A1 格式Range(A1).Formula 读出 A1 中的公式Range(D2).FormulaArray = =SUM(A2:A6)*1） 先在 D2 中输入数组公式Range(D2).Copy Range(D3:D9,E2:E9,F2:F9) 复制、粘贴公式（区间连续或不连续，但不能包括D2）Selection.Formula = Range(e2).Formula 将 E2 中的普通公式填充到当前区域For m = 2 To y 宏中动态引用公式（不适用于数组公式）Range(m & m) = Evaluate(SUMPRODUCT(sheet1!A

19、2:A & x & =sheet2!A & m & )*(sheet1!B2:B & x & =sheet2!B & m & )*(sheet1!L2:L & x & sheet2!L & m & ) + 1 Find 方法的语法.Find ( 要查找的数据 ， ，数据类型 ，XlWhole 或者 xlPart，用来指定所查找的数据是与单元格内容完全匹配还是部分匹配，默认值为xlPart) Sub 由值查行列号 () Find 方法Set r = Range(a1:b12).Find(j6, XlWhole) 对占用内存较多的对象变量，不要时要记住set=nothingOn Error Res

20、ume Next 容错r = Empty （出错）K6 = r.Row 行号L6 = r.Column 列号m6 = r.Address 单元格Set r=nothing置空对象End Sub 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 4 页，共 13 页 - - - - - - - - - Sub 数组查找 () Dim Arr() x = Sheet1.Range(A65536).End(xlUp).Row 行数y = Range(A65536).End(xlUp).Row

21、 行数ReDim Preserve Arr(1 To y) For i = 1 To y On Error Resume Next 容错b = Cells(i, 1) Set r = Sheet1.Range(a1:a & x).Find(b, , , xlWhole) If r = Empty Then Empty（出错）Arr(i) = Else Arr(i) = Sheet1.Cells(r.Row, 2) End If Next B1.Resize(y, 1) = Application.Transpose(Arr) End Sub MATCH函数方法用于取得关键字的行数或列数If I

22、sNumeric(Application.Match(Cells(i, 1), .Range(B1:B & r), 0) Then 关键字不存在时会出错，上句不可少m = Application.Match(Cells(i, 1), .Range(B1:B & r), 0) 行数Sub 查找 () Application.ScreenUpdating = False 禁用刷新With Sheets(资料表 ) x = .Range(R65536).End(xlUp).Row y = Range(F65536).End(xlUp).Row For i = 2 To y If IsNumeric(

23、Application.Match(Cells(i, 6), .Range(R1:R & x), 0) Then m = Application.Match(Cells(i, 6), .Range(R1:R & x), 0) 行数.Range(N & m & :Q & m).Copy Cells(i, 1) End If Next End With End Sub x = a1 多条件语句If x 80 Then 第 1 句d5 = 好 ElseIf x = 0 Then 第 2 句d5 = 最好 Else 其他d5 = 错误 名师资料总结 - - -精品资料欢迎下载 - - - - - -

24、- - - - - - - - - - - - 名师精心整理 - - - - - - - 第 5 页，共 13 页 - - - - - - - - - End If Select Case Sheets.Count 按条件选择执行宏Case Is 1 删除工作表插入新表Case Is = 1 插入新表Case Else End Select End Sub ThisWorkbook.Path ( 或 CurDir) 当前工作簿地址ThisWorkbook.Name 当前工作簿名称ThisWorkbook.FullName 当前工作簿路径和名称ActiveSheet.Name 当前工作表名She

25、et1.ScrollArea = B4:H12 限制表中显示的区间Private Sub Workbook_Open() 打开工作簿时执行ActiveWindow.Close Savechanges:=True 不保存关闭当前工作簿Private Sub Workbook_BeforeClose(Cancel As Boolean) 关闭工作簿时执行Application.Quit 不保存退出Workbooks(1).Close SaveChanges:=False 不保存关闭指定工作簿ActiveWorkbook.Save 保存退出档案.xls, Password:=1234 如文件： 档案

26、， 有密码 1234 用这句代码可以打开excel 模板文件类型：xlt For Each c In Application.Names 隐藏 显示 定义名c.Visible = False Next c MsgBox 宏 & Chr(13) & Chr(13) & 真难学啊！ , , 感叹 消息框格式Chr(13) 换行InputBox 函数：格式如下，第一项为必须外，其余为可选项,可以省略不写，XY 坐标为在窗体上的准确位置。当用户点取消时，返回一个空的字符串( ) 。为了省略某些位置参数，必须加入相应的逗号分界符。InputBox (对话框中的提示信息, 对话框的标题 , 缺省的返回值

27、，X 坐标， Y 坐标) X 坐标和 Y 坐标当你需要为InputBox 窗口指定在屏幕中的位置时用的，单位为象素，一般省略不写。Val 文本变数值Sub 选定单元格 () InputBox 方法Application.Interactive = True Dim a As Range On Error GoTo VeryEnd当按下“取消”按钮时，程序会出错，加上此句与后边VeryEnd:相对应，这样当出错时，程序结束或 Application.Interactive = True Set a = Application. InputBox (prompt:= 使用鼠标选择单元格区域：, T

28、itle:= 格式化区域 , Type:=8) a.NumberFormat = 0.00 单元格式：两位数名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 6 页，共 13 页 - - - - - - - - - VeryEnd: End SubSub 合并单元格 () Application.DisplayAlerts = False 合并时不提问For h = Range(A65536).End(xlUp).Row To 4 Step -1 If Cells(h, 10) = C

29、ells(h + 1, 10) Then Range(Cells(h, 10), Cells(h + 1, 10).Merge Next End Sub Range(B4:D5).Select 合并居中With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ReadingOrder = xlContext End With Selection.Merge (合并单元格 ) a1:g18.Borders.LineStyle = 1 加细边框Range(A6:F10) .Borders.LineSt

30、yle = xlContinuous 加细边框Range(A6:F10).BorderAround Weight:=xlThick 加边 粗框Range(A6:F10) .Borders.LineStyle = xlNone 去边框Sub 循环 () Exit For 跳出循环 end x = Range(A65536).End(xlUp).Row 声明最后一行的行号For h = 5 To x 从第 1 行到最后一行step 步长If Cells(h, 1) 0 Then 判断、赋值Cells(h, 2) = 大于零 ElseIf Cells(h, 1) = 0 Then Cells(h,

31、2) = 等于零 ElseIf Cells(h, 1) p3 Then Exit Sub 此句在达到最大值时退出循环Cells(c, b) = a名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 7 页，共 13 页 - - - - - - - - - Next c, b End Sub Private Sub Worksheet_Change(ByVal Target As Range) 单元格触发事件输入即保存 If Target Then 没有选定或输入字符不触发ActiveWo

32、rkbook.Save 保存End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) 鼠标选定触发Cells.Interior.ColorIndex = 0 整个工作表无色Target.Interior.ColorIndex = 35 鼠标选定区域变色End Sub sheets(数据 ).Visible=xlSheetVeryHidden 隐藏工作表sheets(数据 ).Visible=xlSheetVisible 显示工作表Sheets.Add.Name = 数据 插入名为 数据 的工作表Sub

33、 删除工作表 () 只保留最左边那一个Dim mysheet As Worksheet If Worksheets.Count 1 Then 有 2 个以上才删除Worksheets(2).Select Application.DisplayAlerts = False 删除表时不提问For Each mysheet In Worksheets ActiveWindow.SelectedSheets.Delete Next mysheet End If End Sub Sub 工作表合并() 当前表、目录表和统计表不合并，其他表都合并For Each st In Worksheets If s

34、t.Name ActiveSheet.Name And st.Name 目录 And st.Name 统计 Then st.UsedRange.Offset(2, 0).Copy a65536.End(xlUp).Offset(1, 0) End If Next End Sub Sub 生成目录 () Dim myPath As String Dim myFileName As String Dim i As Long myPath = ThisWorkbook.Path & 指定文件夹myFileName = Dir(myPath, 0) i = 0 Do While Len(myFileN

35、ame) 0 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 8 页，共 13 页 - - - - - - - - - Cells(i + 1, 1) = Left(myFileName, Len(myFileName) - 4) 生成目录myFileName = Dir() i = i + 1 Loop End Sub Sub 批量修改文件名() aaa = ThisWorkbook.Path h = 2 Do oldname = Cells(h, 2) newname = Cel

36、ls(h, 1) If oldname = Empty Then Exit Do On Error Resume Next 出错时继续下一步m= Err.Number错误号数 ,m=0, 无错 Name aaa & & oldname & .xls As aaa & & newname & .xls 实际用时就改一下文件后辍名On Error GoTo 0 h = h + 1 Loop End Sub Sub 删除工作簿 () On Error Resume Next Kill D:123111.xls End Sub Sub 列出工作表名 () 用到循环For k = 1 To Sheets

37、.Count 工作表总数Sheets.Count Cells(k, 1) = Sheets(k).Name 工作表名存放位置Cells(k, 1) 第 K 个工作表名Sheets(k).Name Next End Sub Sub 删除所有定义名称() Dim n As Name For Each n In ThisWorkbook.Names n.Delete Next MsgBox 所有名称已被删除！ End Sub Sub 计算运行时间 () Dim Start As Double, Finish As Double Start = Timer 开始时间- Worksheets(1).Ra

38、nge(H1:H40000).Replace 4, 4.5过程- 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 9 页，共 13 页 - - - - - - - - - Finish = Timer 结束时间MsgBox 本次运行的时间是： & Finish - Start & 秒 End Sub Sub 导入表 2 并填色 () Sheets(1).Rows(13:22).Copy Sheets(2).Rows(2:11) 表 1 复制到表 2（全部）Sheets(2).Rows

39、(2:11).Font.Name = 黑体 将这个范围字体格式为“黑体”Sheet(2).Range(a3).Interior.ColorIndex = 6 在 A3 单元中填进黄色End Sub Sub 判断工作表是否存在() Dim sh As Worksheet Dim d$ d = Day(r5) & 日 新表名来源For Each sh In Worksheets If sh.Name = d Then n = n + 1 Next If n = 0 Then 不存在Worksheets.Add after:=Sheets(Sheets.Count) 在所有表最右边插入一表Activ

40、eSheet.Name = d 新表名为dElseIf n 0 Then 表存在m26 = SSSSS 在 M26 中输入字母End If End Sub Sub 判断工作表是否存在() r = InputBox(, ) For h = 1 To Sheets.Count If r = Sheets(h).Name Then MsgBox r & 存在 End End If Next MsgBox r & 不存在 End Sub Sub 汇总 () Application.ScreenUpdating = False x = Sheet1.Range(A65536).End(xlUp).Row

41、 最后行数 AVG 算术平均数With CreateObject(adodb.connection) .Open provider=microsoft.jet.oledb.4.0;extended properties=Excel 8.0;hdr=no;data source= & ThisWorkbook.FullName p4.CopyFromRecordset .Execute(select f1 fromsheet1$a3:n & x & group by f1) .Close 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - -

42、 - 名师精心整理 - - - - - - - 第 10 页，共 13 页 - - - - - - - - - End With Application.ScreenUpdating = true End Sub 数据库无标题：hdr=no 数据库有标题：hdr=yes 条件取不重复值where f4=3 group by f5Sub 提取多列不重复值() Dim i%, c i = Sheet1.a65536.End(xlUp).Row For Each c In Sheet1.Range(b3:d & i) 数据区 b3:d & i If Application.CountIf(Sheet

43、2.Columns(2), c) = 0 Then Sheet2.b65536.End(xlUp).Offset(1, 0) = c End If Next c End Sub With J3:K257 .HorizontalAlignment = xlCenter 居中.VerticalAlignment = xlCenter End With Sub 更改透视表字段为求和() For h = 2 To 21 m = Cells(4, h).Value Cells(4, h).Select ActiveSheet.PivotTables( 数据透视表1).PivotFields(m).Fun

44、ction = xlSum Next End Sub Sub 错误处理 () Dim I As Long On Error Resume Next 指定发生错误时不处理，直接运行下一条语句I = A1 发生错误 ,由于已经指定了发生错误时不处理，故 Err 对象立即返回直接运行下一条语句。Debug.Print 被忽略的错误 ,错误代码： & Err.Number & 错误信息 & Err.Description & 错误源： & Err.Source & 当前 I 的值 = & I Err.Clear 清空所有错误记录On Error GoTo ERROR1 指定下面的错误发生时直接跳转至E

45、rror1 标号处I = 2147483648# 发生错误 ,由于指定了跳转，故直接转至Error1，而不会再执行下面的语句I = 100 Debug.Print 程序正常返回，当前I 的值 = & I Exit Sub 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 11 页，共 13 页 - - - - - - - - - ERROR1: Debug.Print 发生错误 ,错误代码： & Err.Number & 错误信息 & Err.Description & 错误源： &

46、Err.Source & 当前 I 的值 = & I End Sub Sub 调出窗体 ()UserForm1.Show 0 End Sub LoadPicture函数 返回图片对象Image1图片 6.jpg) Image1.Picture = Nothing 清空图片Private Sub UserForm_Initialize() 初始化装入工作表名Set d = CreateObject(scripting.dictionary) For i = 1 To Worksheets.Count d(Sheets(i).Name) = 1 Next ComboBox7.List = d.ke

47、ys End Sub AppActivate Application.Caption 焦点移到工作表TextBox2.SetFocus 用户窗体控件的激活TextBox1.Activate 工作表控件的激活Application.SendKeys HOME 窗体滚动条停于上边缘For s = 1 To 16 Controls(TextBox & s).Value = 控件循环清空Next IsDate(m)= True 判断日期点无效Private Sub CommandButton1_Click() Unload Me End Sub Private Sub UserForm_QueryCl

48、ose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = True End Sub 点无效Unload UserForm1 窗体退出Application.Visible = True 在窗体退出后，显示excel主窗口条形码控件BarCodeCtrl1 Private Sub CommandButton1_Click() 进度条For t = 1 To 60000 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - -

49、- - - - - 第 12 页，共 13 页 - - - - - - - - - ProgressBar1.Value = t / 100 DoEvents 此句作用： 1、点按钮2 可终止循环2、Label1.Caption 可实时显示Label1.Caption = 程序运行了 & t / 600 * 100 & % Next End Sub LEFT(1.369,InStr(1.369,.)+2) 截取指定位数的数字s = Format(Date, DBNum1$-804yyyy年m 月d 日 aaaa;) MsgBox 今天是 & s 年 Year(Date) 月 Month(Dat

50、e) 日 Day(Date) 日期 DateSerial(2010, 4,1) 第 n 月天数 Day(DateSerial(2010, n+1,0) Format( Date, aaaa ) 星期几Format( Date, yyyy ) 年Format( Date, m ) 月Format( Date, d ) 日Application.Wait Now + TimeValue(00:00:05) 延时执行Sub 缓缓输入句子() m = Array( 好, 好, 学, 习, 天, 天, 向, 上) For i = 0 To 7 Application.Wait Now + TimeVal