【精品】EXCELVBA实用代码收集

excel vba常用代码Excel VBA是一种用于编写宏的编程语言，它可以帮助我们在Excel 中进行自动化操作。

在VBA中，有一些常用的代码，可以帮助我们快速完成一些常见的任务。

本文将介绍一些常用的Excel VBA代码，帮助读者更好地理解并运用它们。

一、数据处理1.1 数据筛选在Excel中，我们经常需要根据某些条件筛选数据。

使用VBA可以实现自动筛选，代码如下：```ActiveSheet.Range("A1:D10").AutoFilter Field:=1, Criteria1:=">10"```以上代码将自动筛选出范围为A1:D10的数据，其中第一列大于10的数据。

1.2 数据排序有时候，我们需要对数据进行排序。

使用VBA可以实现自动排序，代码如下：```ActiveSheet.Range("A1:D10").Sort Key1:=Range("A1"), Order1:=xlAscending```以上代码将自动对范围为A1:D10的数据根据第一列进行升序排序。

1.3 数据透视表数据透视表可以帮助我们对数据进行汇总和分析。

使用VBA可以自动生成数据透视表，代码如下：```ActiveSheet.PivotTableWizard```以上代码将自动生成一个数据透视表。

二、单元格操作2.1 单元格赋值在VBA中，我们可以使用代码将某个值赋给指定的单元格，代码如下：```Range("A1").Value = "Hello World"```以上代码将把"Hello World"赋值给A1单元格。

2.2 单元格格式设置使用VBA可以设置单元格的格式，例如设置字体、颜色、边框等，代码如下：```Range("A1").Font.Bold = TrueRange("A1").Interior.Color = RGB(255, 0, 0)Range("A1").Borders.LineStyle = xlContinuous```以上代码将设置A1单元格的字体为粗体、背景色为红色、边框为实线。

电子表格VBA一些简单而实用的代码1.1.1最简洁的代码统计相对复杂的几个表格（非常有启发）Sub Summary()Worksheets("汇总").[e5].CurrentRegion.ClearContentsOn Error Resume NextDim sh As WorksheetFor Each sh In ActiveWorkbook.SheetsIf <> "汇总" ThenWith sh'获取工作表中数据区域的行数i = .[a65536].End(xlUp).Row'获取工作表中数据区域的列数j = .[iv1].End(xlToLeft).Column'将各工作表区域按R1C1样式存入tempstr字符串中，各区域之间用","隔开 tempstr = tempstr & "'" & & "'!R5C5:R" & i & "C" & j & ","End WithEnd IfNext'清除tempstr字符串中最后一个","tempstr = Left$(tempstr, Len(tempstr) - 1)'将tempstr字符串中的各区域名存入一维数组arr中arr = Split(tempstr, ",")'将各个区域的数据合并计算到"汇总"表Worksheets("汇总").[e5].Consolidate arr, xlSum, True, TrueWorksheets("汇总").[e5] = Sheet1.[e5] End Sub可把如下的几个表汇总成如下的表Excel关于引用有两种表示的方法，即A1 和 R1C1 引用样式。

四、Word vba常用语句100句1、系统参数(01) Application.ActivePrinter‘获取当前打印机(02) Application.Height'当前应用程序文档的高度(03) Application.Width‘当前应用程序文档的宽度(04) Application.Build‘获取Word版本号和编译序号(05) Application.Caption‘当前应用程序名(06) Application.DefaultSaveFormat'返回空字符串，表示Word文档(07) Application.DisplayRecentFiles'返回是否显示最近使用的文档的状态(08) Application.Documents.Count'返回当前打开的文档数(09) Application.FontNames.Count‘返回当前可用的字体数(10) Application.Left‘返回当前文档的水平位置(11) Application.MacroContainer.FullName'返回当前文档名，包括所在路径Application.MacroContainer.pach'返回当前文档路径Application.ActiveDocument.Path‘获得文件的相对路径(12) Application.NormalTemplate.FullName'返回文档标准模板名称及所在位置(13) Application.RecentFiles.Count'返回最近打开的文档数目(14) Application.System.CountryRegion'返回应用程序所在的地区代码(15) Application.System.FreeDiskSpace‘返回应用程序所在磁盘可用空间(16) Application.System.HorizontalResolution'返回显示器的水平分辨率(17) Application.System.VerticalResolution'返回显示器的垂直分辨率(18) nguageDesignation'返回系统所使用的语言(19) Application.System.MathCoprocessorInstalled‘返回系统是否安装了数学协处理器(20) Application.System.OperatingSystem‘返回当前操作系统名(21) Application.System.ProcessorType'返回计算机处理器名(22) Application.System.Version‘返回操作系统的版本号(23) Application.Templates.Count'返回应用程序所使用的模板数(24) erName'返回应用程序用户名(25) Application.Version‘返回应用程序的版本号2、Documents/Document对象(26) ActiveDocument.AttachedTemplate.FullName '返回当前文档采用的模板名及模板所在位置(27) ActiveDocument.Bookmarks.Count'返回当前文档中的书签数(28) ActiveDocument.Characters.Count'返回当前文档的字符数(29) ActiveDocument.CodeName‘返回当前文档的代码名称(30) ments.Count ‘返回当前文档中的评论数(31) ActiveDocument.Endnotes.Count'返回当前文档中的尾注数(32) ActiveDocument.Fields.Count'返回当前文档中的域数目(33) ActiveDocument.Footnotes.Count ‘返回当前文档中的脚注数(34) ActiveDocument.FullName'返回当前文档的全名及所在位置(35) ActiveDocument.HasPassword'当前文档是否有密码保护(36) ActiveDocument.Hyperlinks.Count'返回当前文档中的数(37) ActiveDocument.Indexes.Count'返回当前文档中的索引数(38) ActiveDocument.ListParagraphs.Count'返回当前文档中项目编号或项目符号数(39) ActiveDocument.ListTemplates.Count'返回当前文档中使用的列表模板数(40) ActiveDocument.Paragraphs.Count'返回当前文档中的段落数(41) ActiveDocument.Password=XXX'设置打开文件使用的密码(42) ActiveDocument.ReadOnly'获取当前文档是否为只读属性(43) ActiveDocument.Saved'当前文档是否被保存(44) ActiveDocument.Sections.Count'当前文档中的节数(45) ActiveDocument.Sentences.Count‘当前文档中的语句数(46) ActiveDocument.Shapes.Count'当前文档中的形状数,图形？(47) ActiveDocument.Styles.Count'当前文档中的样式数(48) ActiveDocument.Tables.Count‘当前文档中的表格数(49) ActiveDocument.TablesOfAuthorities.Count ‘返回当前文档中的引文目录数(50) ActiveDocument.TablesOfAuthoritiesCategories.Count ‘返回当前文档中引文目录类别数(51) ActiveDocument.TablesOfContents.Count ‘返回当前文档中的目录数(52) ActiveDocument.TablesOfFigures.Count'返回当前文档中的图表目录数3、Paragraphs/Paragraph对象(53) Selection.Paragraphs.Count'返回所选区域的段落数(54) Selection.Paragraphs.First'返回所选区域中的第一段(55) ActiveDocument.Paragraphs(1).LeftIndent'返回当前文档中第一段的左缩进值(56) ActiveDocument.Paragraphs(1).LineSpacing '返回当前文档中第一段的行距(57) ActiveDocument.Paragraphs(1).OutlineLevel‘返回或设置当前文档中第一段的大纲级别.OutlineLevel = wdOutlineLevel2‘2级.OutlineLevel = wdOutlineLevel3‘3级(58) ActiveDocument.Paragraphs(1).RightIndent ‘返回当前文档中第一段的右缩进量(59) ActiveDocument.Paragraphs(1).SpaceBefore '返回当前文档中第一段的段前间距(60) ActiveDocument.Paragraphs(1).SpaceAfter ‘返回当前文档中第一段的段后间距(61) ActiveDocument.Paragraphs(1).Range.Text'返回当前文档中第一段的容(62) ActiveDocument.Paragraphs(1)Local'返回当前文档中第一段应用的样式名(63) ActiveDocument.Paragraphs(1).Range.Style.Description'返回当前文档中第一段所应用样式的详细描述(64) ActiveDocument.Paragraphs(1)'返回当前文档中第一段所应用样式的字体名(65) ActiveDocument.Paragraphs(1)FarEast'返回或设置一种东亚字体名(66) ActiveDocument.Paragraphs(1).Range.Style.Font.Size '返回或设置当前文档中第一段所应用样式的字体大小(67) ActiveDocument.Paragraphs(1).Range.Style.Font.Spacing '返回或设置字符间距(68) Selection.Words.Count'所选区域的字数Sentences对象(69) Selection.Sentences.Item(1)'所选区域中的第一句的容Words对象(71) ActiveDocument.Words(1).Select'选择当前文档中的第一个词(72) ActiveDocument.Range.Words(1).InsertAfter "我爱你！" '在当前文档中的第一个词后插入“我爱你”4、Characters对象(73) Selection.Characters.Count '当前文档中所选区域的字符数(74) ActiveDocument.Paragraphs(1).Range.InsertParagraphAfter'在当前文档的第一段之后插入一个新段落5、Sections/Section对象(75) ActiveDocument.Sections.First'当前文档的第一节(76) ActiveDocument.Sections.First.PageSetup.BottomMargin '当前文档第一节所在页的底边距(77) ActiveDocument.Sections.First.PageSetup.LeftMargin '当前文档第一节所在页的左边距(78) ActiveDocument.Sections.First.PageSetup.RightMargin '当前文档第一节所在页的右边距(79) ActiveDocument.Sections.First.PageSetup.TopMargin '当前文档第一节所在页的顶边距(80) ActiveDocument.Sections.First.PageSetup.PaperSize '返回或设置当前文档第一节所在页的大小(81) ActiveDocument.Sections.First.PageSetup.PageHeight '返回或设置当前文档第一节所在页的高度(82) ActiveDocument.Sections.First.PageSetup.PageWidth '返回或设置当前文档第一节所在页的宽度(83) ActiveDocument.Sections.Add Range:=myRange'在当前文档中添加新节(84) ActiveDocument.Sections.Item(2)'当前文档中的第二节(85) st.Range.InsertAfter "文档结束！" '在当前文档中最后一节的结尾添加文字“文档结束！”6、Range对象(86) ActiveDocument.Range(Start:=0, End:=10) '表示当前文档前10个字符所组成的一个Range对象(87) Set myRange = ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(2).Range.Start, _End:=ActiveDocument.Paragraphs(4).Range.End) '将当前文档第2段至第4段设置为一个Range对象(88) ActiveDocument.Paragraphs(1).Range.Copy '复制当前文档中的第一段(89) Selection.CopyDocuments.Add.Content.Paste '复制所选容到新文档中(90) ActiveDocument.Bookmarks("Book1").Copy Name:="Book2" '将Book2书签复制Book1书签标记的位置(91) Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=4 '将所选容移至文档中的第4行(92) Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext '将所选容移至下一个表格的第1个单元格(93) Selection.Range.AutoFormat '为所选容套用格式(94) = "Arial" '将当前文档的字体设置为斜体(95) ActiveDocument.Content.Select Selection.Delete '将当前文档中的容删除其它(96) Documents.Add'添加一个新文档(97) Set myTable = ActiveDocument.Tables.Add(Selection.Range, 2, 2) '在当前文档所选区域添加一个2行2列的表格7、文件读写(98) Open "C:\my.txt" For Input As #1'打开一个用于输入的文件并令其编号为1(99) Line Input #1, TextLine'读取被打开用于输入且编号为1的文件(100) Close #1'关闭编号为1的文件一、新建Word引用需要首先创建一个对Word Application 对象的引用。

Excel VBA常用代码总结1改变背景色Range("A1"). = xlNoneColorIndex一览改变文字颜色Range("A1"). = 1获取单元格Cells(1, 2)Range("H7")获取范围Range(Cells(2, 3), Cells(4, 5))Range("a1:c3")'用快捷记号引用单元格Worksheets("Sheet1").[A1:B5]选中某sheetSet NewSheet = Sheets("sheet1")选中或激活某单元格'“Range”对象的的Select方法可以选择一个或多个单元格，而Activate 方法可以指定某一个单元格为活动单元格。

'下面的代码首先选择A1:E10区域，同时激活D4单元格：Range("a1:e10").SelectRange("d4:e5").Activate'而对于下面的代码：Range("a1:e10").SelectRange("f11:g15").Activate'由于区域A1:E10和F11:G15没有公共区域，将最终选择F11:G15，并激活F11单元格。

获得文档的路径和文件名'路徑'名稱'路徑＋名稱'或将ActiveWorkbook换成thisworkbook隐藏文档= False禁止屏幕更新= False禁止显示提示和警告消息= False文件夹做成strPath = "C:\temp\"MkDir strPath状态栏文字表示= "计算中"双击单元格内容变换Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If >= 5And <= 8) ThenIf = "●"Then= ""Else= "●"End IfCancel = TrueEnd IfEnd Sub文件夹选择框方法1Set objShell = CreateObject("")Set objFolder = (0, "文件", 0, 0)If Not objFolder Is NothingThen path= & "\"end ifSet objFolder = NothingSet objShell = Nothing文件夹选择框方法2（推荐）Public Function ChooseFolder() As StringDim dlgOpen As FileDialogSet dlgOpen = (msoFileDialogFolderPicker)With dlgOpen.InitialFileName = & "\"If .Show = -1ThenChooseFolder = .SelectedItems(1)End IfEnd WithSet dlgOpen = NothingEnd Function'使用方法例：Dim path As Stringpath = ChooseFolder()If path <> ""ThenMsgBox"open folder"End If文件选择框方法Public Function ChooseOneFile(Optional TitleStr As String = "Please choose a file", Optional TypesDec As String = "*.*", Optional Exten As String = "*.*") As StringDim dlgOpen As FileDialogSet dlgOpen = (msoFileDialogFilePicker)With dlgOpen.Title = TitleStr.. TypesDec, Exten.AllowMultiSelect = False.InitialFileName =If .Show = -1Then' .AllowMultiSelect = True' For Each vrtSelectedItem In .SelectedItems' MsgBox "Path name: " & vrtSelectedItem' Next vrtSelectedItemChooseOneFile = .SelectedItems(1)End IfEnd WithSet dlgOpen = NothingEnd Function某列到关键字为止循环方法1(假设关键字是end)Set CurrentCell = Range("A1")Do While <> "end"……Set CurrentCell = (1, 0)Loop某列到关键字为止循环方法2(假设关键字是空字符串)i = StartRowDo While Cells(i, 1) <> ""……i = i + 1Loop"For Each...Next 循环(知道确切边界)For Each c In Worksheets("Sheet1").Range("A1:D10").Cells If Abs < Then = 0Next"For Each...Next 循环(不知道确切边界),在活动单元格周围的区域内循环For Each c In If Abs < Then = 0Next某列有数据的最末行的行数的取得(中间不能有空行)lonRow=1Do While Trim(Cells(lonRow, ２).Value) <> ""lonRow = lonRow + 1LooplonRow11 = lonRow11 - 1A列有数据的最末行的行数的取得另一种方法Range("Ａ65536").End(xlUp).Row将文字复制到剪贴板Dim MyData As DataObjectSet MyData = New DataObjectRange("H7").Value取得路径中的文件名Private Function GetFileName(ByVal s As String)Dim sname() As Stringsname = Split(s, "\")GetFileName = sname(UBound(sname))End Function取得路径中的路径名Private Function GetPathName(ByVal s As String)intFileNameStart = InStrRev(s, "\")GetPathName = Mid(s, 1, intFileNameStart)End Function由模板sheet拷贝做成一个新的sheet("template").Copy After:=Set doc_s == "newsheetname" & Format(Now, "yyyyMMddhhmmss")选中当列的最后一个有内容的单元格(中间不能有空行)'删除B3开始到B列最后一个有内容的单元格为止的所有内容Range("B3").SelectRange(Selection, (xlDown)).Select常量定义Private Const StartRow As Integer = 3判断sheet是否存在Private Function IsWorksheet(ByVal strSeetName As String) As Boolean On Error GoTo ErrHandleDim blnRet As BooleanblnRet = IsNull(Worksheets(strSeetName))IsWorksheet = TrueExit FunctionErrHandle:IsWorksheet = FalseEnd Function向单元格中写入公式Worksheets("Sheet1").Range("D6").Formula = "=SUM(D2:D5)"引用命名单元格区域Range("!MyRange")Range("[]Sheet1!Sales"选定命名的单元格区域Reference:="!MyRange"'或者worksheets("sheetname").range("rangename").select使用Dictionary'使用Dictionary需要添加参照Microsoft Scripting RuntimeDim dic As New Dictionary"Table", "Cards"'前面是 Key 后面是 Value"Serial", "serialno""Number", "surface"MsgBox ("Table") '由Key取得Value("Table") '判断某Key是否存在将EXCEL表格中的两列表格插入到一个Dictionary中'函数：在ws工作表中，从iStartRow行开始到没有数据为止，把iKeyCol 列和iKeyCol右一列插入到一个字典中，并返回字典。

EXCEL-VBA-实用代码收集四、Word vba常用语句100句1、系统参数(01) Application.ActivePrinter …获取当前打印机(02) Application.Height '当前应用程序文档的高度(03) Application.Width …当前应用程序文档的宽度(04) Application.Build …获取Word版本号和编译序号(05) Application.Caption …当前应用程序名(06) Application.DefaultSaveFormat '返回空字符串，表示Word文档(07) Application.DisplayRecentFiles '返回是否显示最近使用的文档的状态(08) Application.Documents.Count '返回当前打开的文档数(09) Application.FontNames.Count …返回当前可用的字体数(10) Applicat ion.Left …返回当前文档的水平位置(11) Application.MacroContainer.FullName '返回当前文档名，包括所在路径Application.MacroContainer.pach '返回当前文档路径Application.ActiveDocument.Path …获得文件的相对路径(12) Application.NormalTemplate.FullName '返回文档标准模板名称及所在位置(13) Application.RecentFiles.Count '返回最近打开的文档数目(14) Application.System.CountryRegion '返回应用程序所在的地区代码(15) Application.System.FreeDiskSpace …返回应用程序所在磁盘可用空间(16) Application.System.HorizontalResolution '返回显示器的水平分辨率(17) Application.System.VerticalResolution '返回显示器的垂直(18)/doc/0018125294.html,nguageDesignatio n '返回系统所使用的语言(19) Application.System.MathCoprocessorInstalled …返回系统是否安装了数学协处理器(20) Application.System.OperatingSystem …返回当前操作系统名(21) Application.System.ProcessorType '返回计算机处理器名(22) Application.Sy stem.Version …返回操作系统的版本号(23) Application.Templates.Count '返回应用程序所使用的模板数(24) /doc/0018125294.html,erName '返回应用程序用户名(25) Application.Version …返回应用程序的版本号2、Documents/Document对象(26) ActiveDocument.AttachedTemplate.FullName '返回当前文档采用的模板名及模板所在位置(27) ActiveDocument.Bookmarks.Count '返回当前文档中的书签数(28) ActiveDocument.Characters.Count '返回当前文档的字符数(29) ActiveDocument.CodeName …返回当前文档的代码名称(30)/doc/0018125294.html,ments.Count …返回当前文档中的评论数(31) ActiveDocument.Endnotes.Count '返回当前文档中的尾注数(32) ActiveDocument.Fields.Count '返回当前文档中的域数目(33) ActiveDocument.Footnotes.Count …返回当前文档中的脚(34) ActiveDocument.FullName '返回当前文档的全名及所在位置(35) ActiveDocument.HasPassword '当前文档是否有密码保护(36) ActiveDocument.Hyperlinks.Count '返回当前文档中的链接数(37) ActiveDocument.Indexes.Count '返回当前文档中的索引数(38) ActiveDocument.ListParagraphs.Count '返回当前文档中项目编号或项目符号数(39) ActiveDocument.ListTemplates.Count '返回当前文档中使用的列表模板数(40) ActiveDocument.Paragraphs.Count '返回当前文档中的段落数(41) ActiveDocument.Password=XXX '设置打开文件使用的密码(42) ActiveDocument.ReadOnly '获取当前文档是否为只读属性(43) ActiveDocument.Saved '当前文档是否被保存(44) ActiveDocument.Sections.Count '当前文档中的节数(45) ActiveDocument.Sentences.Count …当前文档中的语句数(46) ActiveDocument.Shapes.Count '当前文档中的形状数,图形？(47) ActiveDocument.Styles.Count '当前文档中的样式数(48) ActiveDocument.Tables.Count …当前文档中的表格数(49) ActiveDocument.TablesOfAuthorities.Count …返回当前文档中的引文目录数(50)ActiveDocument.T ablesOfAuthoritiesCategories.Count …返回当前文档中引文目录类别数(51) ActiveDocument.Tabl esOfContents.Count …返回当前文档中的目录数(52) ActiveDocument.TablesOfFigures.Count '返回当前文档中的图表目录数3、Paragraphs/Paragraph对象(53) Selection.Paragraphs.Count '返回所选区域的段落数(54) Selection.Paragraphs.First '返回所选区域中的第一段(55) ActiveDocument.Paragraphs(1).LeftIndent '返回当前文档中第一段的左缩进值(56) ActiveDocument.Paragraphs(1).LineSpacing '返回当前文档中第一段的行距(57) ActiveDocument.Paragraphs(1).OutlineLevel …返回或设置当前文档中第一段的大纲级别.OutlineLevel = wdOutlineLevel2 …2级.OutlineLevel = wdOutlineLevel3 …3级(58) ActiveDocu ment.Paragraphs(1).RightIndent …返回当前文档中第一段的右缩进量(59) ActiveDocument.Paragraphs(1).SpaceBefore '返回当前文档中第一段的段前间距(60) ActiveDocument.Paragraphs(1).SpaceAfter …返回当前文档中第一段的段后间距(61) ActiveDocument.Paragraphs(1).Range.Text '返回当前文档中第一段的内容(62)ActiveDocument.Paragraphs(1)/doc/0018 125294.html,Local '返回当前文档中第一段应用的样式名(63) ActiveDocument.Paragraphs(1).Range.Style.Description '返回当前文档中第一段所应用样式的详细描述(64)ActiveDocument.Paragraphs(1)/doc/0018 125294.html, '返回当前文档中第一段所应用样式的字体名(65)ActiveDocument.Paragraphs(1)/doc/0018125294.html,FarEast '返回或设置一种东亚字体名(66) ActiveDocument.Paragraphs(1).Range.Style.Font.Size '返回或设置当前文档中第一段所应用样式的字体大小(67)ActiveDocument.Paragraphs(1).Range.Style.Font.Spacing '返回或设置字符间距(68) Selection.Words.Count '所选区域的字数Sentences对象(69) Selection.Sentences.Item(1) '所选区域中的第一句的内容Words对象(71) ActiveDocument.Words(1).Select '选择当前文档中的第一个词(72) ActiveDocument.Range.Words(1).InsertAfter "我爱你！" '在当前文档中的第一个词后插入“我爱你”4、Characters对象(73) Selection.Characters.Count '当前文档中所选区域的字符数(74)ActiveDocument.Paragraphs(1).Range.InsertParagraphAfter'在当前文档的第一段之后插入一个新段落5、Sections/Section对象(75) ActiveDocument.Sections.First '当前文档的第一节(76)ActiveDocument.Sections.First.PageSetup.BottomMargin '当前文档第一节所在页的底边距(77) ActiveDocument.Sections.First.PageSetup.LeftMargin '当前文档第一节所在页的左边距(78) ActiveDocument.Sections.First.PageSetup.RightMargin '当前文档第一节所在页的右边距(79) ActiveDocument.Sections.First.PageSetup.T opMargin '当前文档第一节所在页的顶边距(80) ActiveDocument.Sections.First.PageSetup.PaperSize '返回或设置当前文档第一节所在页的大小(81) ActiveDocument.Sections.First.PageSetup.PageHeight '返回或设置当前文档第一节所在页的高度(82) ActiveDocument.Sections.First.PageSetup.PageWidth '返回或设置当前文档第一节所在页的宽度(83) ActiveDocument.Sections.Add Range:=myRange '在当前文档中添加新节(84) ActiveDocument.Sections.Item(2) '当前文档中的第二节(85)/doc/0018125294.html,st.Range.InsertAfte r "文档结束！" '在当前文档中最后一节的结尾添加文字“文档结束！”6、Range对象(86) ActiveDocument.Range(Start:=0, End:=10) '表示当前文档前10个字符所组成的一个Range对象(87) Set myRange = ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(2).R ange.Start, _End:=ActiveDocument.Paragraphs(4).Range.End) '将当前文档第2段至第4段设置为一个Range对象(88) ActiveDocument.Paragraphs(1).Range.Copy '复制当前文档中的第一段(89) Selection.CopyDocuments.Add.Content.Paste '复制所选内容到新文档中(90) ActiveDocument.Bookmarks("Book1").Copy Name:="Book2" '将Book2书签复制Book1书签标记的位置(91) Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=4 '将所选内容移至文档中的第4行(92) Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext '将所选内容移至下一个表格的第1个单元格(93) Selection.Range.AutoFormat '为所选内容套用格式(94) /doc/0018125294.html, = "Arial" '将当前文档的字体设置为斜体(95) ActiveDocument.Content.Select Selection.Delete '将当前文档中的内容删除其它(96) Documents.Add '添加一个新文档(97) Set myTable = ActiveDocument.T ables.Add(Selection.Range, 2, 2) '在当前文档所选区域添加一个2行2列的表格7、文件读写(98) Open "C:\my.txt" For Input As #1 '打开一个用于输入的文件并令其编号为1(99) Line Input #1, TextLine '读取被打开用于输入且编号为1的文件(100) Close #1 '关闭编号为1的文件一、新建Word引用需要首先创建一个对Word Application 对象的引用。

宏文件集▲打开全部隐藏工作表返回Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = TrueNext iEnd Sub▲循环宏返回Sub 循环()AAA = Range("C2")Dim i As LongDim times As Longtimes = AAA'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range("完成标志") = "完成" Then Exit For '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则只执行一次循环就退出'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For '如果某列出现"完成"内容则退出循环Next iEnd Sub▲录制宏时调用“停止录制”工具栏返回Sub 录制宏时调用停止录制工具栏()mandBars("Stop Recording").Visible = TrueEnd Sub▲高级筛选5列不重复数据至指定表返回Sub 高级筛选5列不重复数据至Sheet2()Sheets("Sheet2").Range("A1:E65536") = "" '清除Sheet2的A:D列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _"A1"), Unique:=TrueSheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"), Order1:=xlAscending,Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub▲双击单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$4"Call 宏1Cancel = TrueCase "$B$4"Call 宏2Cancel = TrueCase "$C$4"Call 宏3Cancel = TrueCase "$E$4"Call 宏4Cancel = TrueEnd SelectEnd Sub▲双击指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then Call 打开隐藏表End Sub▲进入单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)'以单元格进入代替按钮对象调用宏If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$5" '单元地址(Target.Address),或命名单元名字()Call 宏1Case "$B$5"Call 宏2Case "$C$5"Call 宏3End SelectEnd Sub▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call打开隐藏表End Sub▲在多个宏中依次循环执行一个（控件按钮代码）返回Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub▲在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()With CommandButton1If .Caption = "保护工作表" ThenCall 保护工作表.Caption = "取消工作表保护"Exit SubEnd IfIf .Caption = "取消工作表保护" ThenCall 取消工作表保护.Caption = "保护工作表"Exit SubEnd IfEnd WithEnd Sub▲在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = "宏1" ThenCall 宏1.Caption = "宏2"Exit SubEnd IfIf .Caption = "宏2" ThenCall 宏2.Caption = "宏3"Exit SubEnd IfIf .Caption = "宏3" ThenCall 宏3.Caption = "宏1"Exit SubEnd IfEnd WithEnd Sub▲根据A1单元文本隐藏/显示按钮（控件按钮代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("A1") > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub▲当前单元返回按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub▲当前单元内容返回到按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub▲奇偶页分别打印返回Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数MsgBox "现在打印奇数页,按确定开始."For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox "现在打印偶数页,按确定开始."For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub▲自动打印多工作表第一页返回Sub 自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx = InputBox("请输入起始工作表名字:")sy = InputBox("请输入结束工作表名字:")y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub▲查找A列文本循环插入分页符返回Sub 循环插入分页符()' Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页")'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub▲将A列最后数据行以上的所有B列图片大小调整为所在单元大小返回Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing ThenPic.Top = Pic.TopLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub▲返回光标所在行数返回Sub 返回光标所在行数()x = ActiveCell.RowRange("A1") = xEnd Sub▲在A1返回当前选中单元格数量返回Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub▲返回当前工作簿中工作表数量返回Sub 返回当前工作簿中工作表数量()t = Application.Sheets.CountMsgBox tEnd Sub▲返回光标选择区域的行数和列数返回Sub 返回光标选择区域的行数和列数()x = Selection.Rows.County = Selection.Columns.CountRange("A1") = xRange("A2") = yEnd Sub▲工作表中包含数据的最大行数返回Sub 包含数据的最大行数()n = Cells.Find("*", , , , 1, 2).RowMsgBox nEnd Sub▲返回A列数据的最大行数返回Sub 返回A列数据的最大行数()n = Range("a65536").End(xlUp).RowRange("B1") = nEnd Sub▲将所选区域文本插入新建文本框返回Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left +ActiveCell.Width, ActiveCell.Top + ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = "问题：" & nWith Selection.Characters(Start:=1, Length:=3).Font.Name = "黑体".FontStyle = "常规".Size = 12End WithEnd Sub▲批量插入地址批注返回Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionment.Deleter.AddCommentment.Visible = Falsement.Text Text:="本单元格：" & r.Address & " of " & Selection.AddressNextEnd IfEnd Sub▲批量插入统一批注返回Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=msgNextEnd IfEnd Sub▲以A1单元内容批量插入批注返回Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddCommentment.Visible = Falsement.Text Text:=[a1].TextNextEnd IfEnd Sub▲不连续区域插入当前文件名和表名及地址返回Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = "[" + + "]" + +"!" + mycell.AddressNextEnd Sub▲不连续区域录入当前单元地址返回Sub 区域录入当前单元地址()For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub▲连续区域录入当前单元地址返回Sub 连续区域录入当前单元地址()Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub▲返回当前单元地址返回Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub▲不连续区域录入当前日期返回Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")End Sub▲不连续区域录入当前数字日期返回Sub 区域录入当前数字日期()Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")End Sub▲不连续区域录入当前日期和时间返回Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")End Sub▲不连续区域录入对勾返回Sub 批量录入对勾()Selection.FormulaR1C1 = "√"End Sub▲不连续区域录入当前文件名返回Sub 批量录入当前文件名()Selection.FormulaR1C1 = End Sub▲不连续区域添加文本返回Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & "文本内容"NextEnd Sub▲不连续区域插入文本返回Sub 批量插入文本()Dim s As RangeFor Each s In Selections = "文本内容" & sNextEnd Sub▲从指定位置向下同时录入多单元指定内容返回Sub 从指定位置向下同时录入多单元指定内容()Dim arrarr = Array("1", "2", "13", "25", "46", "12", "0", "20")[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub▲按aa工作表A列的内容排列工作表标签顺序返回Sub 按aa工作表A列的内容排列工作表标签顺序()Dim I%, str1$I = 1Sheets("aa").SelectDo While Cells(I, 1).Value <> ""str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets("aa").SelectLoopEnd Sub▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add = nmEnd Sub▲删除全部未选定工作表返回Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As BooleanDim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n - 1If ShtName(i) = TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub▲工作表标签排序返回Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox("工作表按升序排列请选 '是[Y]'. " & vbCrLf & vbCrLf & "工作表按降序排列请选 '否[N]'", vbYesNoCancel, "工作表排序")If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then 'Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse 'Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub▲定义指定工作表标签颜色返回Sub 定义指定工作表标签颜色()Sheets("Sheet1").Tab.ColorIndex = 46End Sub▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets("目录").ActivateIf Err = 0 ThenSheets("目录").UsedRange.DeleteElseSheets.Add = "目录"End IfFor i = 1 To Sheets.CountIf Sheets(i).Name <> "目录" Thens = s + 1Set Rng = Sheets("目录").Cells(((s - 1) Mod 20) + 1, (s - 1) \ 20 + 1 + 1)Rng = Format(s, " 0") & ". " & Sheets(i).NameActiveSheet.Hyperlinks.Add Rng, "#" & Sheets(i).Name & "!A1",ScreenTip:=Sheets(i).NameEnd IfNextSheets("目录").Range("b:iv").EntireColumn.ColumnWidth = 20End Sub▲建立工作表文本目录返回Sub 建立工作表文本目录()Sheets.Add before:=Sheets(1)Sheets(1).Name = "目录"For i = 2 To Sheets.CountCells(i - 1, 1) = Sheets(i).Name'Sheets(1).Hyperlinks.Add Cells(i - 1, 1), "#" & Sheets(i).Name & "!A1" '添加超链接NextEnd Sub▲查另一文件的全部表名返回Sub 查另一文件的全部表名()On Error Resume NextDim i%Dim sh As WorksheetApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=ThisWorkbook.Path & "\2.xls"Windows("1.xls").Activate '当前文件名称Sheets("Sheet1").Select '当前表名称i = 1 '将表名称返回到第1行For Each sh In Workbooks("2.xls").WorksheetsCells(i, 1) = '将表名称返回到第1列i = i + 1 '返回每个表名称向下移动1行Next shWindows("2.xls").Close '关闭对象文件Application.ScreenUpdating = TrueEnd Sub▲当前单元录入计算机名返回Sub 当前单元录入计算机名()Selection = Environ("COMPUTERNAME")'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲当前单元录入计算机用户名返回 Sub 当前单元录入计算机用户名()Selection = Environ("Username")'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲解除全部工作表保护返回Sub 解除全部工作表保护()Dim n As IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext nEnd Sub▲为指定工作表加指定密码保护表返回Sub 为指定工作表加指定密码保护表()Sheet10.Protect Password:="123"End Sub▲在有密码的工作表执行代码返回Sub 在有密码的工作表执行代码()Sheets("1").Unprotect Password:=123 '假定表名为“1”，密码为“123” 打开工作表Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True '隐藏C列空值行Sheets("1").Protect Password:=123 '重新用密码保护工作表End Sub▲执行前需要验证密码的宏(控件按钮代码)返回Private Sub CommandButton1_Click()If InputBox("请输入密码：") <> "123" Then '密码是123MsgBox "密码错误,按确定退出!", 64, "提示"Exit SubEnd IfCells(1, 1) = 10End SubSub 执行前需要验证密码的宏()If InputBox("请输入您的使用权限:", "系统提示") = 123 Then重排窗口 '要执行的宏代码或宏名称ElseMsgBox "对不起,您没有使用该宏的权限,按确定键后退出!"End IfEnd Sub▲拷贝A1公式和格式到A2返回Sub 拷贝A1公式到A2()Workbooks("临时表").Sheets("表1").Range("A1").CopyWorkbooks("临时表").Sheets("表2").Range("A2").PasteSpecialEnd Sub▲复制单元数值返回Sub 复制数值()s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2")Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = sEnd Sub▲插入数值条件格式返回Sub 插入数值条件格式()Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="70"Selection.FormatConditions(1).Interior.ColorIndex = 45Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _Formula1:="55"Selection.FormatConditions(2).Interior.ColorIndex = 39Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="60"Selection.FormatConditions(3).Interior.ColorIndex = 34End Sub▲插入透明批注返回Sub 插入透明批注()Selection.AddCommentment.Visible = FalseDim XS As WorksheetFor i = 1 To ments.Countments(i).Text "透明批注"ments(i).Shape.Fill.Visible = msoFalseNextEnd Sub▲添加文本返回Sub 添加文本()Selection = Selection + "×" '不可在数字后添加文本'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲光标定位到指定工作表A列最后数据行下一单元返回Sub 光标定位到指定工作表A列最后数据行下一单元()a = Sheets("数据库").[a65536].End(xlUp).RowSheets("数据库").SelectRange("A" & a + 1).SelectEnd Sub▲定位选定单元格式相同的全部单元格返回Sub 定位选定单元格式相同的全部单元格()Dim FirstCell As Range, FoundCell As RangeDim AllCells As RangeWith Application.FindFormat.Clear.NumberFormatLocal = Selection.NumberFormatLocal.HorizontalAlignment = Selection.HorizontalAlignment.VerticalAlignment = Selection.VerticalAlignment.WrapText = Selection.WrapText.Orientation = Selection.Orientation.AddIndent = Selection.AddIndent.IndentLevel = Selection.IndentLevel.ShrinkToFit = Selection.ShrinkToFit.MergeCells = Selection.MergeCells = .Font.FontStyle = Selection.Font.FontStyle.Font.Size = Selection.Font.Size.Font.Strikethrough = Selection.Font.Strikethrough.Font.Subscript = Selection.Font.Subscript.Font.Underline = Selection.Font.Underline.Font.ColorIndex = Selection.Font.ColorIndex.Interior.ColorIndex = Selection.Interior.ColorIndex.Interior.Pattern = Selection.Interior.Pattern.Locked = Selection.Locked.FormulaHidden = Selection.FormulaHiddenEnd WithSet FirstCell = edRange.Find(what:="", searchformat:=True)If FirstCell Is Nothing ThenExit SubEnd IfSet AllCells = FirstCellSet FoundCell = FirstCellDoSet FoundCell = edRange.Find(After:=FoundCell, what:="",searchformat:=True)If FoundCell Is Nothing Then Exit DoSet AllCells = Union(FoundCell, AllCells)If FoundCell.Address = FirstCell.Address Then Exit DoLoopAllCells.SelectEnd Sub▲按当前单元文本定位返回Sub 按当前单元文本定位()ABC = SelectionDim aa As RangeFor Each a In edRangeIf a Like ABC ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲按固定文本定位返回Sub 文本定位()Dim aa As RangeFor Each a In edRangeIf a Like "*合计*" ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲删除包含固定文本单元的行或列返回Sub 删除包含固定文本单元的行或列()DoCells.Find(what:="哈哈").ActivateSelection.EntireRow.Delete '删除行' Selection.EntireColumn.Delete '删除列Loop Until Cells.Find(what:="哈哈") Is NothingEnd Sub▲定位数据及区域以上的空值返回Sub 定位数据及区域以上的空值()Dim aa As RangeFor Each a In edRangeIf a Like 〈0 ThenIf aa Is Nothing ThenSet aa = a.CellsElseSet aa = Union(aa, a.Cells)End IfEnd IfNextaa.SelectEnd Sub▲右侧单元自动加5(工作表代码)返回Private Sub Worksheet_Change(ByVal Target As Range)Application.EnableEvents = FalseTarget.Offset(0, 1) = Target + 5Application.EnableEvents = TrueEnd Sub▲当前单元加2返回Sub 当前单元加2()Selection = Selection + 2'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容End Sub▲A列等于A列减B列返回Sub A列等于A列减B列()For i = 1 To 23Cells(i, 1) = Cells(i, 1) - Cells(i, 2)NextEnd Sub▲用于光标选定多区域跳转指定单元(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal T As Range)a = Array([b6:b7], [e6], [h6])For i = 0 To 2If Not Application.Intersect(T, a(i)) Is Nothing Then[a1].Select: Exit ForEnd IfNextEnd Sub▲将A1单元录入的数据累加到B1单元（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)Dim t As LongIf Target.Address = "$A$1" Thent = Sheet1.Range("$B$1").ValueSheet1.Range("$B$1").Value = t + Target.ValueEnd IfEnd Sub▲在指定颜色区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeFor Each myrg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> "√", "√", "")NextEnd Sub▲在指定区域选择单元时添加/取消"√"（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count <= 15 ThenIf Not Application.Intersect(Target, Range("D6:D20")) Is Nothing ThenFor Each Rng In SelectionWith RngIf .Value = "" Then.Value = "√"Else.Value = ""End IfEnd WithNextEnd IfEnd IfEnd Sub▲双击指定单元，循环录入文本（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)If T.Address <> "$A$1" Then Exit SubCancel = TrueT = IIf(T = "好", "中", IIf(T = "中", "差", "好"))End Sub双击指定单元，循环录入文本（工作表代码）Dim nums As BytePrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address = "$A$1" Thennums = nums Mod 3 + 1Target = Mid("上中下", nums, 1)Target.Offset(1, 0).SelectEnd IfEnd Sub▲单元区域引用（工作表代码）返回Private Sub Worksheet_Activate()Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").ValueEnd Sub▲在指定区域选择单元时数值加1（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect([a1:e10], Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub▲混合文本的编号返回Sub 混合文本的编号()Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3,100)) + 1)End Sub▲指定区域单元双击数据累加（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Not Application.Intersect([A1:Y100], Target) Is Nothing Thenoldvalue = Val(Target.Value)inputvalue = InputBox("请输入数量,按ENTER键确认!", "数值累加器")Target.Value = oldvalue + inputvalueEnd IfEnd Sub▲选择单元区域触发事件（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = "$A$1:$B$2" ThenMsgBox "你选择了$A$1:$B$2单元"End IfEnd Sub▲当修改指定单元内容时自动执行宏（工作表代码）返回Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then重排窗口End IfEnd Sub▲被指定单元内容限制执行宏返回Sub 被指定单元限制执行宏()If Range("$A$1") = "关闭" Then Exit Sub窗口End Sub▲双击单元隐藏该行（工作表代码）返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Rows(Target.Row).Hidden = TrueEnd Sub▲高亮显示行（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = 2Rows("1:2").Interior.ColorIndex = 40 '保持1至2行的颜色推荐39,22,40,Rows(Target.Row).Interior.ColorIndex = 35 '高亮推荐颜色35,20,24,34,37,40,15End Sub▲高亮显示行和列（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34Columns(Target.Column).Interior.ColorIndex = 34End Sub▲为指定工作表设置滚动范围（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)Sheet1.ScrollArea = "A1:M30"End Sub▲在指定单元记录打印和预览次数（工作簿代码）返回Private Sub Workbook_BeforePrint(Cancel As Boolean)Range("A1") = 1 + Range("A1")End Sub▲自动数字金额转大写（工作表代码）返回Private Sub Worksheet_Change(ByVal M As Range)On Error Resume Nexty = Int(Round(100 * Abs(M)) / 100)j = Round(100 * Abs(M) + 0.00001) - y * 100f = (j / 10 - Int(j / 10)) * 10A = IIf(y < 1, "", Application.Text(y, "[DBNum2]") & "元")b = IIf(j > 9.5, Application.Text(Int(j / 10), "[DBNum2]") & "角", IIf(y < 1,"", IIf(f > 1, "零", "")))c = IIf(f < 1, "整", Application.Text(Round(f, 0), "[DBNum2]") & "分")M = IIf(Abs(M) < 0.005, "", IIf(M < 0, "负" & A & b & c, A & b & c))End Sub▲将全部工作表的A1单元作为单击按钮（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)If Target.Address = "$A$1" ThenCall 宏名End IfEnd Sub▲闹钟——到指定时间执行宏（工作簿代码）返回Private Sub Workbook_Open()Application.OnTime ("11:45:00"), "提示1" '宏名字Application.OnTime ("12:00:00"), "提示2" '宏名字End Sub▲改变Excel界面标题的宏（工作簿代码）返回Private Sub Workbook_Open()Application.Caption = "春节快乐"End Sub▲在指定工作表的指定单元返回光标当前多选区地址（工作簿代码）返回Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)Worksheets("表2").Range("A1") = Target.Address(0, 0)End Sub▲B列录入数据时在A列返回记录时间（工作表代码）返回Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub▲当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）返回Public Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [A1:A1000]) Is Nothing ThenIf Target.Column = 1 ThenTarget.Offset(, 1) = DateTarget.Offset(, 2) = TimeEnd IfEnd IfEnd SubPublic Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, [A1:A1000]) Is Nothing ThenIf Target.Column = 1 ThenTarget.Offset(, 1) = Format(Now(), "yyyy-mm-dd")Target.Offset(, 2) = Format(Now(), "h:mm:ss")End IfEnd IfEnd Sub▲指定单元显示光标位置内容（工作表代码）返回Private Sub Worksheet_SelectionChange(ByVal T As Range)Sheets(1).Range("A1") = SelectionEnd Sub▲每编辑一个单元保存文件返回Private Sub Worksheet_Change(ByVal Target As Range)ThisWorkbook.SaveEnd Sub▲指定允许编辑区域返回Sub 指定允许编辑区域()ActiveSheet.ScrollArea = "B8:G15"End Sub▲解除允许编辑区域限制返回Sub 解除允许编辑区域限制()ActiveSheet.ScrollArea = ""End Sub▲删除指定行返回Sub 删除指定行()Workbooks("临时表").Sheets("表2").Range("5:5").DeleteEnd Sub▲删除A列为指定内容的行返回Sub 删除A列为指定内容的行()Dim a, b As Integera = Sheet1.[a65536].End(xlUp).RowFor b = a To 2 Step -1If Cells(b, 1).Value = "删除" ThenRows(b).DeleteEnd IfNextEnd Sub▲删除A列非数字单元行返回Sub 删除A列非数字单元行()i = [a65536].End(xlUp).RowRange("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.DeleteEnd Sub▲有条件删除当前行返回Sub 有条件删除当前行()If [A1] = 2 Or [B1] = "删除" ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub▲选择下一行返回Sub 选择下一行()ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.SelectEnd Sub▲选择第5行开始所有数据行返回Sub 选择第5行开始所有数据行A()Dim i%i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues,SearchDirection:=xlPrevious).EntireRow.RowRows("5:" & i).SelectEnd SubSub 选择第5行开始所有数据行B()Rows("5:" & Cells.Find("*", , , , 1, 2).Row).SelectEnd Sub▲选择光标或选区所在行返回Sub 选择光标或选区所在行()Selection.EntireRow.Select▲选择光标或选区所在列返回Sub 选择光标或选区所在列()Selection.EntireColumn.SelectEnd Sub▲光标定位到名称指定位置返回Sub 定位()Application.Goto Range(Evaluate("名称"))End Sub▲选择名称定义的数据区返回Sub 选择名称定义的数据区()[数据区].Select '插入名称要使用INDIRECT函数'Range("数据区").Select 或者'Sheet1.Range("数据区").Select 或者End Sub▲选择到指定列的最后行返回Sub 选择到指定列的最后行()Range("C4:G" & [G65536].End(xlUp).Row).SelectEnd Sub▲将Sheet1的A列的非空值写到Sheet2的A列返回Sub 将Sheet1的A列的非空值写到Sheet2的A列()Sheet1.Columns("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1]End Sub▲将名称1的数据写到名称2返回Sub Macro2()Range("位置2") = Range("位置1").Value▲单元反选返回Sub 单元反选()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress As String, taddress As Stringraddress = Selection.Addresstaddress = edRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = "=0"raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address.DeleteEnd WithActiveSheet.Range(raddress).SelectApplication.ScreenUpdating = TrueEnd Sub▲调整选中对象中的文字返回Sub 调整选中对象中的文字()'文字居中、自动调整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd WithEnd Sub▲去除指定范围内的对象返回Sub 去除指定范围内的对象()。

VBA常用技巧目录VBA常用技巧---------------------------------------------------- 第1章Range（单元格）对象--------------------------------- 技巧1 ---------------------------------- 单元格的引用方法1-1 ---------------------------------- 使用Range属性1-2 ---------------------------------- 使用Cells属性1-3 ------------------------------------ 使用快捷记号1-4 --------------------------------- 使用Offset属性1-5 --------------------------------- 使用Resize属性1-6 ---------------------------------- 使用Union方法1-7 ------------------------------ 使用UsedRange属性1-8 -------------------------- 使用CurrentRegion属性技巧2 ------------------------------ 选定单元格区域的方法2-1 --------------------------------- 使用Select方法2-2 ------------------------------- 使用Activate方法2-3 ----------------------------------- 使用Goto方法技巧3 -------------- 获得指定行、列中的最后一个非空单元格技巧4 ---------------------------------------- 定位单元格技巧5 ---------------------------------------- 查找单元格5-1 ----------------------------------- 使用Find方法5-2 --------------------------------- 使用Like运算符技巧6 -------------------------------- 替换单元格内字符串技巧7 ------------------------------------ 复制单元格区域技巧8 ------------------------------ 仅复制数值到另一区域8-1 ---------------------------------- 使用选择性粘贴8-2 ---------------------------------- 直接赋值的方法技巧9 ---------------------------- 单元格自动进入编辑状态技巧10 ------------------------------- 禁用单元格拖放功能2技巧11 ----------------------------------- 单元格格式操作11-1 ----------------------------- 单元格字体格式设置11-2 ----------------------------- 设置单元格内部格式11-3 --------------------------- 为单元格区域添加边框11-4 ----------------------- 灵活设置单元格的行高列宽错误!未定义书签。

前言我们平时在工作表单元格的公式中常常使用函数，Excel自带的常用的函数多达300多个，功能强大，丰富多彩，但是在VBA中不能直接应用，必须在函数名前面加上对象，比如：Application.WorksheetFunction.Sum(arg1,arg2,arg3)。

而能在VBA中直接应用的函数也有几十个，下面将逐一详细介绍常用的40个VBA 函数，以供大家学习参考。

第1.1例 ASC函数一、题目：要求编写一段代码，运行后得到字符串”Excel”的首字母和”e”的ASCII 值。

二、代码：Sub 示例_1_01()Dim myNum1%, myNum2%myNum1 = Asc("Excel") '返回69myNum2 = Asc("e") '返回101[a1] = "myNum1= ": [b1] = myNum1[a2] = "myNum2= ": [b2] = myNum2End Sub三、代码详解1、Sub 示例_1_01()：宏程序的开始语句。

2、Dim myNum1%, myNum2%：变量myNum1和myNum2声明为整型变量。

也可以写为 Dim myNum1 As Integer 。

Integer 变量存储为 16位（2 个字节）的数值形式，其范围为 -32,768 到 32,767 之间。

Integer 的类型声明字符是百分比符号 (%)。

3、myNum1 = Asc("Excel")：把Asc函数的值赋给变量myNum1。

Asc函数返回一个 Integer，代表字符串中首字母的字符的ASCII代码。

语法Asc(string)必要的 string（字符串）参数可以是任何有效的字符串表达式。

如果 string 中没有包含任何字符，则会产生运行时错误。

4、myNum2 = Asc("e")：把Asc函数的值赋给变量myNum2。

实用的EXCEL VBA编程小结:最近单位内部的项目里要用到些报表EXCEL的生成，虽说JAVA 的POI可以有这能力,但觉得还是可能比较麻烦，因此还是转用。

net来搞，用Visual Studio2003配合office 2003,用到了一些VBA,因此小结并归纳之，选了些资料归纳在这里，以备今后查考首先创建Excel 对象，使用ComObj:Dim ExcelID as Excel。

ApplicationSet ExcelID as new Excel。

Application1) 显示当前窗口：ExcelID。

Visible := True；2）更改Excel 标题栏:ExcelID。

Caption ：= ’应用程序调用Microsoft Excel’；3) 添加新工作簿：ExcelID。

WorkBooks。

Add;4) 打开已存在的工作簿：ExcelID。

WorkBooks。

Open( ’C:\Excel\Demo。

xls’）；5) 设置第2个工作表为活动工作表：ExcelID。

WorkSheets[2］.Activate;或ExcelID.WorkSheets[ ’Sheet2’］.Activate;6）给单元格赋值:ExcelID。

Cells［1，4]。

Value ：= ’第一行第四列'；7) 设置指定列的宽度（单位:字符个数），以第一列为例:ExcelID。

ActiveSheet.Columns［1].ColumnsWidth := 5；8）设置指定行的高度（单位：磅)(1磅＝0。

035厘米)，以第二行为例：ExcelID。

ActiveSheet.Rows［2］。

RowHeight := 1/0.035；// 1厘米9) 在第8行之前插入分页符:ExcelID。

WorkSheets［1]。

Rows［8].PageBreak := 1；10）在第8列之前删除分页符：ExcelID。

Excel-vba宏代码-大全宏文件集▲打开全部隐藏工作表返回Sub 打开全部隐藏工作表()Dim i As IntegerFor i = 1 To Sheets.CountSheets(i).Visible = TrueNext iEnd Sub▲循环宏返回Sub 循环()AAA = Range("C2")Dim i As LongDim times As Longtimes = AAA'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 过滤一行If Range("完成标志") = "完成" Then Exit For '如果名为'完成标志'的命名单元的值等于'完成',则退出循环,如果一开始就等于'完成',则只执行一次循环就退出'If Sheets("传送参数").Range("A" & i).Text = "完成" Then Exit For '如果某列出现"完成"内容则退出循环Next iEnd Sub▲录制宏时调用“停止录制”工具栏返回Sub 录制宏时调用停止录制工具栏()/doc/4911298482.html,mandBars("Stop Recording").Visible = TrueEnd Sub▲高级筛选5列不重复数据至指定表返回Sub 高级筛选5列不重复数据至Sheet2()Sheets("Sheet2").Range("A1:E65536") = "" '清除Sheet2的A:D 列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _"A1"), Unique:=TrueSheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"), Order1:=xlAscending,Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _:=xlPinYinEnd Sub▲双击单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$4"Call 宏1Cancel = TrueCase "$B$4"Call 宏2Cancel = TrueCase "$C$4"Call 宏3Cancel = TrueCase "$E$4"Call 宏4Cancel = TrueEnd SelectEnd Sub▲双击指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then Call 打开隐藏表End Sub▲进入单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)'以单元格进入代替按钮对象调用宏If Range("$A$1") = "关闭" Then Exit SubSelect Case Target.AddressCase "$A$5" '单元地址(Target.Address),或命名单元名字(/doc/4911298482.html,)Call 宏1Case "$B$5"Call 宏2Case "$C$5"Call 宏3End SelectEnd Sub▲进入指定区域单元执行宏(工作表代码)返回Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("$A$1") = "关闭" Then Exit SubIf Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call打开隐藏表▲在多个宏中依次循环执行一个（控件按钮代码）返回Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase 0宏1RunMacro = 1Case 1宏2RunMacro = 2Case 2宏3RunMacro = 0End SelectEnd Sub▲在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()With CommandButton1If .Caption = "保护工作表" ThenCall 保护工作表.Caption = "取消工作表保护"Exit SubEnd IfIf .Caption = "取消工作表保护" ThenCall 取消工作表保护.Caption = "保护工作表"Exit SubEnd IfEnd With▲在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）返回Option ExplicitPrivate Sub CommandButton1_Click()With CommandButton1If .Caption = "宏1" ThenCall 宏1.Caption = "宏2"Exit SubEnd IfIf .Caption = "宏2" ThenCall 宏2.Caption = "宏3"Exit SubEnd IfIf .Caption = "宏3" ThenCall 宏3.Caption = "宏1"Exit SubEnd IfEnd WithEnd Sub▲根据A1单元文本隐藏/显示按钮（控件按钮代码）返回Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range("A1") > 2 ThenCommandButton1.Visible = 1ElseCommandButton1.Visible = 0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub▲当前单元返回按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()ActiveCell = CommandButton1.CaptionEnd Sub▲当前单元内容返回到按钮名称（控件按钮代码）返回Private Sub CommandButton1_Click()CommandButton1.Caption = ActiveCellEnd Sub▲奇偶页分别打印返回Sub 奇偶页分别打印()Dim i%, Ps%Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数MsgBox "现在打印奇数页,按确定开始."For i = 1 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iMsgBox "现在打印偶数页,按确定开始."For i = 2 To Ps Step 2ActiveSheet.PrintOut from:=i, To:=iNext iEnd Sub▲自动打印多工作表第一页返回Sub 自动打印多工作表第一页() Dim sh As IntegerDim xDim yDim syDim syzx = InputBox("请输入起始工作表名字:")sy = InputBox("请输入结束工作表名字:")y = Sheets(x).Indexsyz = Sheets(sy).IndexFor sh = y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1, To:=1Next shEnd Sub▲查找A列文本循环插入分页符返回Sub 循环插入分页符()' Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容Dim i As LongDim times As Longtimes = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页")'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i = 1 To timesCall 插入分页符Next iEnd SubSub 插入分页符()Cells.Find(What:="分页", After:=ActiveCell, LookIn:=xlValues, LookAt:= _xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _.ActivateActiveWindow.SelectedSheets.HPageBreaks.AddBefore:=ActiveCellEnd SubSub 取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub▲将A列最后数据行以上的所有B列图片大小调整为所在单元大小返回Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture, i&i = [A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing ThenPic.Top = Pic.T opLeftCell.TopPic.Left = Pic.TopLeftCell.LeftPic.Height = Pic.TopLeftCell.HeightPic.Width = Pic.TopLeftCell.WidthEnd IfNextEnd Sub▲返回光标所在行数返回Sub 返回光标所在行数()x = ActiveCell.RowRange("A1") = xEnd Sub▲在A1返回当前选中单元格数量返回Sub 在A1返回当前选中单元格数量()[A1] = Selection.CountEnd Sub▲返回当前工作簿中工作表数量返回Sub 返回当前工作簿中工作表数量()t = Application.Sheets.CountMsgBox tEnd Sub▲返回光标选择区域的行数和列数返回Sub 返回光标选择区域的行数和列数()x = Selection.Rows.County = Selection.Columns.CountRange("A1") = xRange("A2") = yEnd Sub▲工作表中包含数据的最大行数返回Sub 包含数据的最大行数()n = Cells.Find("*", , , , 1, 2).RowMsgBox nEnd Sub▲返回A列数据的最大行数返回Sub 返回A列数据的最大行数() n = Range("a65536").End(xlUp).RowRange("B1") = nEnd Sub▲将所选区域文本插入新建文本框返回Sub 将所选区域文本插入新建文本框()For Each rag In Selectionn = n & rag.Value & Chr(10)NextActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizon tal, ActiveCell.Left +ActiveCell.Width, ActiveCell.T op + ActiveCell.Height, 250#, 100).SelectSelection.Characters.Text = "问题：" & nWith Selection.Characters(Start:=1, Length:=3).Font.Name = "黑体".FontStyle = "常规".Size = 12End WithEnd Sub▲批量插入地址批注返回Sub 批量插入地址批注()On Error Resume NextDim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selection/doc/4911298482.html,ment.Deleter.AddComment/doc/4911298482.html,ment.Visible = False /doc/4911298482.html,ment.Text Text:="本单元格：" & r.Address & " of " & Selection.AddressNextEnd IfEnd Sub▲批量插入统一批注返回Sub 批量插入统一批注()Dim r As Range, msg As Stringmsg = InputBox("请输入欲批量插入的批注", "提示", "随便输点什么吧")If Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddComment/doc/4911298482.html,ment.Visible = False /doc/4911298482.html,ment.TextText:=msgNextEnd IfEnd Sub▲以A1单元内容批量插入批注返回Sub 以A1单元内容批量插入批注()Dim r As RangeIf Selection.Cells.Count > 0 ThenFor Each r In Selectionr.AddComment/doc/4911298482.html,ment.Visible = False /doc/4911298482.html,ment.TextText:=[a1].T extNextEnd IfEnd Sub▲不连续区域插入当前文件名和表名及地址返回Sub 批量插入当前文件名和表名及地址()For Each mycell In Selectionmycell.FormulaR1C1 = "[" + /doc/4911298482.html, + "]" + /doc/4911298482.html, +"!" + mycell.AddressNextEnd Sub▲不连续区域录入当前单元地址返回Sub 区域录入当前单元地址() For Each mycell In Selectionmycell.FormulaR1C1 = mycell.AddressNextEnd Sub▲连续区域录入当前单元地址返回Sub 连续区域录入当前单元地址()Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"Selection.CopySelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=FalseEnd Sub▲返回当前单元地址返回Sub 返回当前单元地址()d = ActiveCell.Address[A1] = dEnd Sub▲不连续区域录入当前日期返回Sub 区域录入当前日期()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")End Sub▲不连续区域录入当前数字日期返回Sub 区域录入当前数字日期() Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")End Sub▲不连续区域录入当前日期和时间返回Sub 区域录入当前日期和时间()Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")End Sub▲不连续区域录入对勾返回Sub 批量录入对勾()Selection.FormulaR1C1 = "√"End Sub▲不连续区域录入当前文件名返回Sub 批量录入当前文件名()Selection.FormulaR1C1 = /doc/4911298482.html,End Sub▲不连续区域添加文本返回Sub 批量添加文本()Dim s As RangeFor Each s In Selections = s & "文本内容"NextEnd Sub▲不连续区域插入文本返回Sub 批量插入文本()Dim s As RangeFor Each s In Selections = "文本内容" & sNextEnd Sub▲从指定位置向下同时录入多单元指定内容返回Sub 从指定位置向下同时录入多单元指定内容()Dim arrarr = Array("1", "2", "13", "25", "46", "12", "0", "20")[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)End Sub▲按aa工作表A列的内容排列工作表标签顺序返回Sub 按aa工作表A列的内容排列工作表标签顺序()Dim I%, str1$I = 1Sheets("aa").SelectDo While Cells(I, 1).Value <> ""str1 = Trim(Cells(I, 1).Value)Sheets(str1).SelectSheets(str1).Move after:=Sheets(I)I = I + 1Sheets("aa").SelectLoopEnd Sub▲以A1单元文本作表名插入工作表返回Sub 以A1单元文本作表名插入工作表()Dim nm As Stringnm = [a1]Sheets.Add/doc/4911298482.html, = nmEnd Sub▲删除全部未选定工作表返回Sub 删除全部未选定工作表()Dim sht As Worksheet, n As Integer, iFlag As BooleanDim ShtName() As Stringn = ActiveWindow.SelectedSheets.CountReDim ShtName(1 To n)n = 1For Each sht In ActiveWindow.SelectedSheetsShtName(n) = /doc/4911298482.html,n = n + 1NextApplication.DisplayAlerts = FalseFor Each sht In SheetsiFlag = FalseFor i = 1 To n - 1If ShtName(i) = /doc/4911298482.html, TheniFlag = TrueExit ForEnd IfNextIf Not iFlag Then sht.DeleteNextApplication.DisplayAlerts = TrueEnd Sub▲工作表标签排序返回Sub 工作表标签排序()Dim i As Long, j As Long, nums As Long, msg As Longmsg = MsgBox("工作表按升序排列请选'是[Y]'. " & vbCrLf & vbCrLf & "工作表按降序排列请选 '否[N]'", vbYesNoCancel, "工作表排序")If msg = vbCancel Then Exit Subnums = Sheets.CountIf msg = vbYes Then 'Sort ascendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) < UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iElse 'Sort descendingFor i = 1 To numsFor j = i To numsIf UCase(Sheets(j).Name) > UCase(Sheets(i).Name) ThenSheets(j).Move Before:=Sheets(i)End IfNext jNext iEnd IfEnd Sub▲定义指定工作表标签颜色返回Sub 定义指定工作表标签颜色() Sheets("Sheet1").T ab.ColorIndex = 46End Sub▲在目录表建立本工作簿中各表链接目录返回Sub 在目录表建立本工作簿中各表链接目录()Dim s%, Rng As RangeOn Error Resume NextSheets("目录").ActivateIf Err = 0 ThenSheets("目录").UsedRange.DeleteElseSheets.Add/doc/4911298482.html, = "目录" End If。

001.批量创建工作表2020年4月17日4:04Sub NewSht()Dim shtActive As Worksheet, sht As WorksheetDim i As Long, strShtName As StringOn Error Resume Next '当代码出错时继续运行Set shtActive = ActiveSheetFor i = 2 To shtActive.Cells(Rows.Count, 1).End(xlUp).Row'单元格A1是标题，跳过，从第2行开始遍历工作表名称strShtName = shtActive.Cells(i, 1).Value'工作表名强制转换为字符串类型Set sht = Sheets(strShtName)'当工作簿不存在工作表Sheets(strShtName)时，这句代码会出错，然后…… If Err Then'如果代码出错，说明不存在工作表Sheets(t)，则新建工作表Worksheets.Add , Sheets(Sheets.Count)'新建一个工作表，位置放在所有已存在工作表的后面 = strShtName'新建的工作表必然是活动工作表，为之命名Err.Clear'清除错误状态End IfNextshtActive.Activate'重新激活原工作表End Sub002.删除全部工作表2020年11月25日22:13Sub DelShet() '删除所有工作表Dim sht As WorksheetApplication.ScreenUpdating = False '关屏幕刷新Application.DisplayAlerts = False '关警告信息 On Error Resume NextFor Each sht In Worksheetssht.Delete '遍历工作表删除NextApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd Sub003.提取工作表名字2020年11月25日22:14Sub GetShtByVba()Dim sht As Worksheet, k As LongApplication.ScreenUpdating = Falsek = 1Range("a:b").Clear '清空数据Range("a:a").NumberFormat = "@" '设置文本格式For Each sht In Worksheets '遍历工作表取表名k = k + 1Cells(k, 1) = NextRange("a1:b1") = Array("工作表名", "是否删除") Application.ScreenUpdating = TrueEnd Sub004.删除指定工作表2020年11月25日22:15Sub DelShtByVba()Dim sht As Worksheet, i As Long, rApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume Nextr = Range("a1").CurrentRegion '数据装入数组rFor i = 2 To UBound(r) '遍历并删除工作表If r(i, 2) = "删除" Then Worksheets(CStr(r(i, 1))).Delete NextApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd Sub005.生成带超链接的工作表目录2020年11月25日22:15Sub ml()Dim sht As Worksheet, i&, strShtName$Columns(1).ClearContents '清空A列数据Cells(1, 1) = "目录" '第一个单元格写入标题"目录"i = 1 '将i的初值设置为1.For Each sht In Worksheets '循环当前工作簿的每个工作表strShtName = If strShtName <> Then '如果sht的名称不是当前工作表的名称则开始在当前工作表建立超链接i = i + 1 '累加工作表数量ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _SubAddress:="'" & strShtName & "'!a1", TextToDisplay:=strShtName'建超链接End IfNextEnd Sub006.在各个分表创建返回总表的命令按钮2020年11月25日22:16Dim strShtName As StringSub Mybutton()Dim sht As Worksheet, btn As ButtonOn Error Resume NextFor Each sht In WorksheetsWith shtIf .Name <> strShtName Then.Shapes(strShtName).Delete'删除原有的名称为shtn的按钮，避免重复创建Set btn = .Buttons.Add(0, 0, 60, 30)'使用add方法在工作表中添加一个按钮控件，add方法语法如下:表达式.Add(left,right,width,height)'新建按钮，释义见小贴士With btn.Name = strShtName'命令按钮命名.Characters.Text = "返回总表"'按钮的文本内容.OnAction = "LinkTable"'指定按钮控件所执行的宏命令End WithEnd IfEnd WithNextSet btn = NothingEnd SubSub LinkTable()strShtName = "总表"'指定了返回总表的名字，可以根据实际需要修改为目标表的名称，比如“目录”。

1、打开显示登录窗体代码打开隐藏表格，显示登录窗体private Sub Workbook_open()Application.Visible = falseUserForm1.Showend Sub2、固定账号、密码登录窗体设置（1）制作窗体（2）登录验证Private Sub CommandButton1_Click() If TextBox1 = "admin" ThenIf TextBox2 <> 123 ThenMsgBox "密码错误"Exit SubElseMsgBox "登录成功”"Unload MeApplication.Visible = TrueSheet1.ActivateEnd IfElseMsgBox "账号不存在"End IfEnd Sub（3）退出按钮Private Sub CommandButton2_Click() Unload MeThisWorkbook.CloseEnd Sub(4)打开注册窗体Private Sub CommandButton3_Click() UserForm2.ShowEnd Sub（5）唯一关闭代码Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode <> 1 Then Cancel = TrueEnd Sub3、注册账号（1）制作注册账号窗体（2）注册代码Private Sub CommandButton1_Click()Dim zh As Range, zt As RangeIf TextBox1 = "" Then MsgBox "未填入账户": Exit SubIf TextBox2 <> TextBox3 Then MsgBox "密码不一致": Exit SubSet zh = Sheets("注册").Range("a:a").Find(TextBox1.Text, , , 1)If zh Is Nothing ThenSet zt = Sheets("注册").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) zt = TextBox1.Textzt.Offset(0, 1) = TextBox2.Textzt.Offset(0, 2) = NowMsgBox "注册成功"Unload MeElseMsgBox "账号已经存在，请更换其他账号"End IfEnd Sub4、查找筛选代码Private Sub TextBox1_Change()If Len(TextBox1.Value) = 0 ThenSheet1.AutoFilterMode = FalseElseIf Sheet1.AutoFilterMode = True ThenSheet1.AutoFilterMode = FalseEnd IfSheet1.Range("B7:P" & Rows.Count).AutoFilter _field:=4, Criteria1:="*" & TextBox1.Value & "*"End IfEnd Sub5、多账号密码验证代码Private Sub CommandButton1_Click()If Len(TextBox1) = 0 Then MsgBox "未输入账号": Exit SubDim zh As RangeSet zh = Sheets("注册").Range("a:a").Find(TextBox1.Text, , , 1) If Not zh Is Nothing ThenIf TextBox2.Text <> zh.Offset(0, 1) ThenMsgBox "密码错误"Exit SubElseMsgBox "登录成功"Unload MeApplication.Visible = TrueSheet1.ActivateEnd IfElseMsgBox "账号不存在"End IfEnd Sub6、默认打开第一个工作表Private Sub Workbook_Open()Sheet1.ActivateEnd Sub7、退出保存工作表Private Sub Workbook_BeforeClose(Cancel As Boolean) ThisWorkbook.SaveEnd Sub。

1：打开所有隐藏工作表Sub打开所有隐藏工作表()Dim i As IntegerFor i=1To Sheets.CountSheets(i).Visible=TrueNext iEnd Sub2：循环宏Sub循环()AAA=Range("C2")Dim i As LongDim times As Longtimes=AAA'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i=1To timesCall过滤一行If Range("完成标志")="完成"ThenExit For'假如名为'完成标志'的命名单元的值等于'完成',则退出循环,假如一开始就等于'完成',则只执行一次循环就退出'If Sheets("传送参数").Range("A"&i).Text="完成"ThenExit For'假如某列出现"完成"内容则退出循环Next iEnd Sub3：录制宏时调用“停止录制”工具栏Sub录制宏时调用停止录制工具栏()mandBars("Stop Recording").Visible=TrueEnd Sub4：高级筛选5列不重复数据至指定表Sub高级筛选5列不重复数据至Sheet2()Sheets("Sheet2").Range("A1:E65536")=""'清除Sheet2的A:D列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy,CopyToRange:=Sheet2.Range(_"A1"),Unique:=TrueSheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"),Order1:=xlAscending,Header:=xlGuess,_OrderCustom:=1,MatchCase:=False,Orientation:=xlTopToBottom,SortMethod_ :=xlPinYinEnd Sub5：双击单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range,Cancel As Boolean)If Range("$A$1")="关闭"ThenExit SubSelect Case Target.AddressCase"$A$4"Call宏1Cancel=TrueCase"$B$4"Call宏2Cancel=TrueCase"$C$4"Call宏3Cancel=TrueCase"$E$4"Call宏4Cancel=TrueEnd SelectEnd Sub6：双击指定区域单元执行宏(工作表代码)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range,Cancel As Boolean) If Range("$A$1")="关闭"Then Exit SubIf Not Application.Intersect(Target,Range("A4:A9","C4:C9"))Is Nothing Then Call打开隐藏表End Sub7：进入单元执行宏(工作表代码)Private Sub Worksheet_SelectionChange(ByVal Target As Range)'以单元格进入代替按钮对象调用宏If Range("$A$1")="关闭"Then Exit SubSelect Case Target.AddressCase"$A$5"'单元地址(Target.Address),或命名单元名字()Call宏1Case"$B$5"Call宏2Case"$C$5"Call宏3End SelectEnd Sub8：进入指定区域单元执行宏(工作表代码)Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Range("$A$1")="关闭"Then Exit SubIf Not Application.Intersect(Target,Range("A4:A9","C4:C9"))Is Nothing Then Call打开隐藏表End Sub9：在多个宏中依次循环执行一个（控件按钮代码）Private Sub CommandButton1_Click()Static RunMacro As IntegerSelect Case RunMacroCase0宏1RunMacro=1Case1宏2RunMacro=2Case2宏3RunMacro=0End SelectEnd Sub10：在两个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Private Sub CommandButton1_Click()With CommandButton1If.Caption="保护工作表"ThenCall保护工作表.Caption="取消工作表保护"Exit SubEnd IfIf.Caption="取消工作表保护"ThenCall取消工作表保护.Caption="保护工作表"Exit SubEnd IfEnd WithEnd Sub11：在三个宏中依次循环执行一个并相应修改按钮名称（控件按钮代码）Option Explicit Private Sub CommandButton1_Click()With CommandButton1If.Caption="宏1"ThenCall宏1.Caption="宏2"Exit SubEnd IfIf.Caption="宏2"ThenCall宏2.Caption="宏3"Exit SubEnd IfIf.Caption="宏3"ThenCall宏3.Caption="宏1"Exit SubEnd IfEnd WithEnd Sub12：根据A1单元文本隐藏/显示按钮（控件按钮代码）Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range("A1")>2ThenCommandButton1.Visible=1ElseCommandButton1.Visible=0End IfEnd SubPrivate Sub CommandButton1_Click()重排窗口End Sub13：当前单元返回按钮名称（控件按钮代码）Private Sub CommandButton1_Click()ActiveCell=CommandButton1.CaptionEnd Sub14：当前单元内容返回到按钮名称（控件按钮代码）Private Sub CommandButton1_Click()CommandButton1.Caption=ActiveCellEnd Sub15：奇偶页分别打印Sub奇偶页分别打印()Dim i%,Ps%Ps=ExecuteExcel4Macro("GET.DOCUMENT(50)")'总页数MsgBox"现在打印奇数页,按确定开始."For i=1To Ps Step2ActiveSheet.PrintOut from:=i,To:=iNext iMsgBox"现在打印偶数页,按确定开始."For i=2To Ps Step2ActiveSheet.PrintOut from:=i,To:=iNext iEnd Sub16：自动打印多工作表第一页Sub自动打印多工作表第一页()Dim sh As IntegerDim xDim yDim syDim syzx=InputBox("请输入起始工作表名字:")sy=InputBox("请输入结束工作表名字:")y=Sheets(x).Indexsyz=Sheets(sy).IndexFor sh=y To syzSheets(sh).SelectSheets(sh).PrintOut from:=1,To:=1Next shEnd Sub17：查找A列文本循环插入分页符Sub循环插入分页符()'Selection=Workbooks("临时表").Sheets("表2").Range("A1")调用指定地址内容Dim i As LongDim times As Longtimes=Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"),"分页")'times代表循环次数，执行前把times赋值即可(不可小于1，不可大于2147483647)For i=1To timesCall插入分页符Next iEnd SubSub插入分页符()Cells.Find(What:="分页",After:=ActiveCell,LookIn:=xlValues,LookAt:=_xlPart,SearchOrder:=xlByRows,SearchDirection:=xlNext,MatchCase:=False)_.ActivateActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCellEnd SubSub取消原分页()Cells.SelectActiveSheet.ResetAllPageBreaksEnd Sub18：将A列最后数据行以上的所有B列图片大小调整为所在单元大小Sub将A列最后数据行以上的所有B列图片大小调整为所在单元大小()Dim Pic As Picture,i&i=[A65536].End(xlUp).RowFor Each Pic In Sheet1.PicturesIf Not Application.Intersect(Pic.TopLeftCell,Range("B1:B"&i))Is Nothing Then Pic.Top=Pic.TopLeftCell.TopPic.Left=Pic.TopLeftCell.LeftPic.Height=Pic.TopLeftCell.HeightPic.Width=Pic.TopLeftCell.WidthEnd IfNextEnd Sub19：返回光标所在行数Sub返回光标所在行数()x=ActiveCell.RowRange("A1")=xEnd Sub20：在A1返回当前选中单元格数量Sub在A1返回当前选中单元格数量()[A1]=Selection.CountEnd Sub21：返回当前工作簿中工作表数量Sub返回当前工作簿中工作表数量()t=Application.Sheets.CountMsgBox tEnd Sub93：B列录入数据时在A列返回记录时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column=2ThenTarget.Offset(,-1)=NowEnd IfEnd Sub94：当指定区域修改时在其右侧的2个单元返回当前日期和时间（工作表代码）Public Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target,[A1:A1000])Is Nothing Then If Target.Column=1ThenTarget.Offset(,1)=DateTarget.Offset(,2)=TimeEnd IfEnd IfEnd SubPublic Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target,[A1:A1000])Is Nothing Then If Target.Column=1ThenTarget.Offset(,1)=Format(Now(),"yyyy-mm-dd")Target.Offset(,2)=Format(Now(),"h:mm:ss")End IfEnd IfEnd Sub95：指定单元显示光标位置内容（工作表代码）Private Sub Worksheet_SelectionChange(ByVal T As Range) Sheets(1).Range("A1")=SelectionEnd Sub96：每编辑一个单元保存文件Private Sub Worksheet_Change(ByVal Target As Range) ThisWorkbook.SaveEnd Sub97：指定允许编辑区域Sub指定允许编辑区域()ActiveSheet.ScrollArea="B8:G15"End Sub98：解除允许编辑区域限制Sub解除允许编辑区域限制()ActiveSheet.ScrollArea=""End Sub99：删除指定行Sub删除指定行()Workbooks("临时表").Sheets("表2").Range("5:5").Delete End Sub100：删除A列为指定内容的行Sub删除A列为指定内容的行()Dim a,b As Integera=Sheet1.[a65536].End(xlUp).RowFor b=a To2Step-1If Cells(b,1).Value="删除"ThenRows(b).DeleteEnd IfNextEnd SubExcel VBA常用代码总结1改变背景色Range("A1").Interior.ColorIndex = xlNone ColorIndex一览•改变文字颜色Range("A1").Font.ColorIndex = 1•获取单元格Cells(1, 2)Range("H7")•获取范围Range(Cells(2, 3), Cells(4, 5))Range("a1:c3")'用快捷记号引用单元格Worksheets("Sheet1").[A1:B5]•选中某sheetSet NewSheet = Sheets("sheet1")NewSheet.Select•选中或激活某单元格'“Range”对象的的Select方法可以选择一个或多个单元格，而Activate方法可以指定某一个单元格为活动单元格。

Excel VBA 常用代码50例001。

用命令按扭打印一个sheet1中B2:M30区域中的内容?我想在Sheet2中制件一个命令按扭, 打印表Sheet1中的[B2:M30] 区域中的内容?解答：可以将打印区域设为b2：m30，然后打印，如：sheets("sheet1").printarea="b2:m30"sheets("sheet1").printout随手写的，你可以试试看。

最简单的方法是：你先录制宏，在录制宏过程中，跑到页面设置里面，把打印范围设置到你想要的范围。

然后退出，停止录制宏，你就可以得到一些代码！002。

能否对一列中的文字统一去掉最后一个字?这些文字不统一,有些字数多,有些字数少。

如何处理?我用{"&-}不行解答：=REPLACE(A1,LEN(A1),1," ")(在过渡列进行)003.能否根据单元格数值自动标记序号？各位大佬，一工作表有两列，“序号”及“金额”，能否将金额不等于0的行自动标上序号呢？如无现成的函数，应怎样设置？解答：Dim xuhao As Integerxuhao = 1Range("b2").SelectDo While Selection <> ""If Selection <> 0 ThenActiveCell.Previous.Value = xuhaoxuhao = xuhao + 1End IfActiveCell.Offset(1, 0).Range("a1").SelectLoop004.求教自定义函数查询了一些自定义函数的例子都是单变量的。

自定义函数能否建立“(As Range) As Interger”的函数，应该可以的，请各位大师赐教！请以“∑x2”为例，万分感谢！(该用"For Each ...Next"，就是还不知道如何引用Range中的每个值，请高手指点。

1.删除重复行 (1)2. ActiveX控件的相关操作 (1)3. 单元格内容匹配 (2)4。

单元格填充公式 (3)5。

弹出打开对话框 (3)6. 操作文件夹下的所有工作簿 (3)7. 获取数据区域的最后一行和最后一列 (4)8. 获取列的字母顺序[A~IV］ (4)9. 自定义函数返回数组并填充至单元格区域 (4)10. 绘制曲线图 (5)11. 单元格区域拷贝 (5)12. 操纵数据库(查、增、删、改） (6)13。

待定XX (6)1.删除重复行关键字：[a65536］.End（xlUp).Row、Offset（)、相关双层循环Sub RemoveDuplicate(）'删除重复行For i = [a65536].End(xlUp)。

Row — 1 To 1 Step —1 '按倒叙删除For j = [a65536]。

End(xlUp).Row To i + 1 Step —1If Cells(i， 1)。

Value = Cells（j， 1）.Value ThenRows（i)。

DeleteEnd IfNextNextEnd SubSub RemoveItem()'删除相邻重复，但不删除隔行重复Dim i As LongWith Range（"A2”）’以A2为基准进行单元格偏移Do While .Offset(i, 0)If .Offset（i， 0)。

Value = .Offset（i — 1, 0）。

Value Then 。

Offset（i, 0）.EntireRow.Delete i = i + 1LoopEnd WithEnd Sub2.ActiveX控件的相关操作关键字：ActiveX、OLEObjects、ActiveSheet。

OLEObjects遍历控件Dim c As ObjectFor Each c In ActiveSheet.OLEObjectsIf = ”ComboBox” & i Then’…………。

Excel VBA 常用代码50例001。

用命令按扭打印一个sheet1中B2:M30区域中的内容?我想在Sheet2中制件一个命令按扭, 打印表Sheet1中的[B2:M30] 区域中的内容?解答：可以将打印区域设为b2：m30，然后打印，如：sheets("sheet1").printarea="b2:m30"sheets("sheet1").printout随手写的，你可以试试看。

最简单的方法是：你先录制宏，在录制宏过程中，跑到页面设置里面，把打印范围设置到你想要的范围。

然后退出，停止录制宏，你就可以得到一些代码！002。

能否对一列中的文字统一去掉最后一个字?这些文字不统一,有些字数多,有些字数少。

如何处理?我用{"&-}不行解答：=REPLACE(A1,LEN(A1),1," ")(在过渡列进行)003.能否根据单元格数值自动标记序号？各位大佬，一工作表有两列，“序号”及“金额”，能否将金额不等于0的行自动标上序号呢？如无现成的函数，应怎样设置？解答：Dim xuhao As Integerxuhao = 1Range("b2").SelectDo While Selection <> ""If Selection <> 0 ThenActiveCell.Previous.Value = xuhaoxuhao = xuhao + 1End IfActiveCell.Offset(1, 0).Range("a1").SelectLoop004.求教自定义函数查询了一些自定义函数的例子都是单变量的。

自定义函数能否建立“(As Range) As Interger”的函数，应该可以的，请各位大师赐教！请以“∑x2”为例，万分感谢！(该用"For Each ...Next"，就是还不知道如何引用Range中的每个值，请高手指点。

【转载】EXCELVBA20个有⽤的ExcelVBA代码1.显⽰多个隐藏的⼯作表如果你的⼯作簿⾥⾯有多个隐藏的⼯作表，你需要花很多时间⼀个⼀个的显⽰隐藏的⼯作表。

下⾯的代码，可以让你⼀次显⽰所有的⼯作表Sub UnhideAllWoksheets()Dim ws As WorksheetFor Each ws In ActiveWorkbook.Worksheetsws.Visible = xlSheetVisibleNext wsEnd Sub2.隐藏除了活动⼯作表外的所有⼯作表如果你做的报表，希望隐藏除了报表⼯作表以外的所有⼯作表，则可以⽤⼀下代码来实现：Sub HideAllExcetActiveSheet()Dim ws As WorksheetFor Each ws In ThisWorkbook.WorksheetsIf <> Thenws.Visible = xlSheetHiddenEnd ifNext wsEnd Sub3.⽤VBA代码按字母的顺序对⼯作表进⾏排序如果你有⼀个包含多个⼯作表的⼯作簿，并且希望按字母对⼯作表进⾏排序，那么下⾯的代码，可以派上⽤场。

Sub SortSheetsTabName()Application.ScreenUpdating = FalseDim ShCount As Integer, i As Integer, j As IntegerShCount = Sheets.CountFor i = 1 To ShCount - 1For j = i + 1 To ShCountIf Sheets(j).Name < Sheets(i).Name ThenSheets(j).Move before:=Sheets(i)End IfNext jNext iApplication.ScreenUpdating = TrueEnd Sub4.⼀次性保护所有的⼯作表如果⼯作薄⾥⾯有多个⼯作表，并且希望保护所有的⼯作表，那么下⾯的代码，可以派上⽤场。

Excel VBA常用代码总结1•改变背景色Range("A1").Interior.ColorIndex = xlNoneColorIndex一览•改变文字颜色Range("A1").Font.ColorIndex = 1•获取单元格Cells(1, 2)Range("H7")•获取范围Range(Cells(2, 3), Cells(4, 5))Range("a1:c3")'用快捷记号引用单元格Worksheets("Sheet1").[A1:B5]•选中某sheetSet NewSheet = Sheets("sheet1")NewSheet.Select•选中或激活某单元格'“Range”对象的的Select方法可以选择一个或多个单元格，而Activate方法可以指定某一个单元格为活动单元格。

'下面的代码首先选择A1:E10区域，同时激活D4单元格：Range("a1:e10").SelectRange("d4:e5").Activate'而对于下面的代码：Range("a1:e10").SelectRange("f11:g15").Activate'由于区域A1:E10和F11:G15没有公共区域，将最终选择F11:G15，并激活F11单元格。

•获得文档的路径和文件名ActiveWorkbook.Path '路徑 '名稱ActiveWorkbook.FullName '路徑＋名稱'或将ActiveWorkbook换成thisworkbook•隐藏文档Application.Visible = False•禁止屏幕更新Application.ScreenUpdating = False•禁止显示提示和警告消息Application.DisplayAlerts = False•文件夹做成strPath = "C:\temp\"MkDir strPath•状态栏文字表示Application.StatusBar = "计算中"•双击单元格内容变换Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If (Target.Cells.Row >= 5And Target.Cells.Row <= 8) Then If Target.Cells.Value = "●"ThenTarget.Cells.Value = ""ElseTarget.Cells.Value = "●"End IfCancel = TrueEnd IfEnd Sub•文件夹选择框方法1Set objShell = CreateObject("Shell.Application")Set objFolder = objShell.BrowseForFolder(0, "文件", 0, 0)If Not objFolder Is NothingThen path= objFolder.self.Path & "\"end ifSet objFolder = NothingSet objShell = Nothing•文件夹选择框方法2（推荐）Public Function ChooseFolder() As StringDim dlgOpen As FileDialogSet dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)With dlgOpen.InitialFileName = ThisWorkbook.path & "\"If .Show = -1ThenChooseFolder = .SelectedItems(1)End IfEnd WithSet dlgOpen = NothingEnd Function'使用方法例：Dim path As Stringpath = ChooseFolder()If path <> ""ThenMsgBox"open folder"End If•文件选择框方法Public Function ChooseOneFile(Optional TitleStr As String = "Please choose a file", Optional TypesDec As String = "*.*", Optional Exten As String = "*.*") As StringDim dlgOpen As FileDialogSet dlgOpen = Application.FileDialog(msoFileDialogFilePicker)With dlgOpen.Title = TitleStr.Filters.Clear.Filters.Add TypesDec, Exten.AllowMultiSelect = False.InitialFileName = ThisWorkbook.PathIf .Show = -1Then' .AllowMultiSelect = True' For Each vrtSelectedItem In .SelectedItems' MsgBox "Path name: " & vrtSelectedItem' Next vrtSelectedItemChooseOneFile = .SelectedItems(1)End IfEnd WithSet dlgOpen = NothingEnd Function•某列到关键字为止循环方法1(假设关键字是end)Set CurrentCell = Range("A1")Do While CurrentCell.Value <> "end"……Set CurrentCell = CurrentCell.Offset(1, 0)Loop•某列到关键字为止循环方法2(假设关键字是空字符串)i = StartRowDo While Cells(i, 1) <> ""……i = i + 1Loop•"For Each...Next 循环(知道确切边界)For Each c In Worksheets("Sheet1").Range("A1:D10").Cells If Abs(c.Value) < 0.01Then c.Value = 0Next•"For Each...Next 循环(不知道确切边界),在活动单元格周围的区域内循环For Each c In ActiveCell.CurrentRegion.CellsIf Abs(c.Value) < 0.01Then c.Value = 0Next•某列有数据的最末行的行数的取得(中间不能有空行)lonRow=1Do While Trim(Cells(lonRow, ２).Value) <> ""lonRow = lonRow + 1LooplonRow11 = lonRow11 - 1•A列有数据的最末行的行数的取得另一种方法Range("Ａ65536").End(xlUp).Row•将文字复制到剪贴板Dim MyData As DataObjectSet MyData = New DataObjectMyData.SetText Range("H7").ValueMyData.PutInClipboard•取得路径中的文件名Private Function GetFileName(ByVal s As String)Dim sname() As Stringsname = Split(s, "\")GetFileName = sname(UBound(sname))End Function•取得路径中的路径名Private Function GetPathName(ByVal s As String)intFileNameStart = InStrRev(s, "\")GetPathName = Mid(s, 1, intFileNameStart)End Function•由模板sheet拷贝做成一个新的sheetThisWorkbook.Worksheets("template").CopyAfter:=ThisWorkbook.Worksheets(Sheets.Count)Set doc_s = ThisWorkbook.Worksheets(Sheets.Count)doc_ = "newsheetname" & Format(Now, "yyyyMMddhhmmss")•选中当列的最后一个有内容的单元格(中间不能有空行)'删除B3开始到B列最后一个有内容的单元格为止的所有内容Range("B3").SelectRange(Selection, Selection.End(xlDown)).SelectSelection.ClearContents•常量定义Private Const StartRow As Integer = 3•判断sheet是否存在Private Function IsWorksheet(ByVal strSeetName As String) As Boolean On Error GoTo ErrHandleDim blnRet As BooleanblnRet = IsNull(Worksheets(strSeetName))IsWorksheet = TrueExit FunctionErrHandle:IsWorksheet = FalseEnd Function•向单元格中写入公式Worksheets("Sheet1").Range("D6").Formula = "=SUM(D2:D5)"•引用命名单元格区域Range("MyBook.xls!MyRange")Range("[Report.xls]Sheet1!Sales"•选定命名的单元格区域Application.Goto Reference:="MyBook.xls!MyRange"'或者worksheets("sheetname").range("rangename").selectSelection.ClearContents•使用Dictionary'使用Dictionary需要添加参照Microsoft Scripting RuntimeDim dic As New Dictionarydic.Add "Table", "Cards"'前面是 Key 后面是 Valuedic.Add "Serial", "serialno"dic.Add "Number", "surface"MsgBox dic.Item("Table") '由Key取得Valuedic.Exists("Table") '判断某Key是否存在•将EXCEL表格中的两列表格插入到一个Dictionary中'函数：在ws工作表中，从iStartRow行开始到没有数据为止，把iKeyCol列和iKeyCol右一列插入到一个字典中，并返回字典。

EXCELVBA常用代码集1.显示活动工作簿名称MsgBox "当前活动工作簿是" & 2.保存活动工作簿Activeworkbook.Save3.保存所有打开的工作簿关闭EXCELFor Each W in Application.WorkbooksW.SaveNext WApplication.Quit4.将网格线设置为蓝色ActiveWindow.GridlineColorIndex = 55.将工作表sheet1隐藏Sheet1.Visible = xlSheetVeryHidden6.将工作表Shtte1显示Sheet1.Visible = xlSheetVisible7.单击某单元格,该单元格所在的行以蓝色背景填充,字体颜色为白色Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)If Target.Row >= 2 Then’第二行以下的区域On Error Resume Next[ChangColor_With1].FormatConditions.Delete = "ChangColor_With1"With [ChangColor_With1].FormatConditions.Delete.Add xlExpression, , "TRUE".Item(1).Interior.ColorIndex = 5.Item(1).Font.ColorIndex = 2End WithEnd IfEnd Sub8.使窗体在启动的时候自动最大化Private Sub UserForm_Initialize()Application.WindowState = xlMaximizedWith ApplicationMe.Top = .TopMe.Left = .LeftMe.Height = .HeightMe.Width = .WidthEnd WithEnd Sub9.不保存工作簿退出EXCELApplication.DisplayAlerts = FalseApplication.Quit10.使窗体的关闭按纽不好用Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)If CloseMode = vbformcontrdmenu ThenMsgBox "请用关闭按钮关闭窗口!!", 64, "提示"Cancel = TrueEnd IfEnd Sub11.使窗体在3秒后自动关闭Private Sub UserForm_Activate()Application.Wait Now + TimeValue("00:00:03")UserForm1.HideEnd Sub12.启动窗体的时候自动使Label1显示Sheet1工作表3列,8行的内容Private Sub UserForm_Activate()Label1.Caption = Sheets("sheet1").Cells(3, 8)End Sub13.让按纽CommandButton1在窗体上以不可用状态显示CommandButton1.Enabled = False14.让按纽Commandbutton1在窗体上以隐藏方式存在CommandButton10.Visible = False15.点击Commandbutton1按纽进入”工资”工作表Sheets("工资").Select16.在Textbox1中输入数据,窗体可显示出”工资”工作表中与输入内容关联的项Private Sub TextBox1_Change()For X = 1 To Application.CountA(Sheets("工资").Range("a:a")) If Sheets("工资").Cells(X, 1) = TextBox1.Text Then’在工资表第一列查找与Textbox1输入相符的项Label2.Caption = Sheets("工资").Cells(X, 2)’在Label2中显示Textbox1数据所在的第二列的数据Label7.Caption = Sheets("工资").Cells(X, 3)’在Label2中显示Textbox1数据所在的第三列的数据End IfNextEnd Sub17.使EXCEL启动的时候自动最小化/最大化Private Sub Workbook_Open()Application.WindowState = xlMinimized’最小化Application.WindowState = xlMaximized’最大化End Sub18.在Label25以数字的形式显示TextBox12×Label14的结果Label25.Caption = Val(TextBox12.Text) * Val(Label14.Caption)19.单选按纽名与Sheet6工作表名相同OptionButton6.Caption = 20.”登陆”窗体的显示,隐藏登陆.Show’显示登陆.Hide’隐藏21.使窗体的标题栏不显示(1)插入类模块” CFormChanger”代码如下:Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As LongPrivate Const GWL_STYLE As Long = (-16)Private Const WS_CAPTION As Long = &HC00000Dim hWndForm As Long……………………………………………………………………………………………………………..Public Property Set Form(oForm As Object) '29If Val(Application.Version) < 9 ThenhWndForm = FindWindow("ThunderXFrame", oForm.Caption)ElsehWndForm = FindWindow("ThunderDFrame", oForm.Caption)End IfSetFormStyleEnd Property……………………………………………………………………………………………………………….Private Sub SetFormStyle()Dim iStyle As Long, hMenu As Long, hID As Long, iItems As IntegeriStyle = GetWindowLong(hWndForm, GWL_STYLE)iStyle = iStyle And Not WS_CAPTIONiStyle = iStyle Or WS_THICKFRAMESetWindowLong hWndForm, GWL_STYLE, iStyleDrawMenuBar hWndFormEnd Sub(2)在所在窗体代码里声明Dim oFormChanger As New CFormChanger(3).在窗体的Activate事件中插入代码Set oFormChanger.Form = MeMe.SpecialEffect = fmspecia1EffectRaised以上三步每一步都不可缺少,否则不能完成.22.单击某单元格,该单元格所在的行与列都以蓝色背景填充Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)If Target.Row >= 2 Then’第二行以下的所有列On Error Resume Next[ChangColor_With2].FormatConditions.Delete[ChangColor_With3].FormatConditions.Delete = "ChangColor_With2" = "ChangColor_With3"With [ChangColor_With2].FormatConditions.Delete.Add xlExpression, , "TRUE".Item(1).Interior.ColorIndex = 5End WithWith [ChangColor_With3].FormatConditions.Delete.Add xlExpression, , "TRUE".Item(1).Interior.ColorIndex = 5End WithEnd IfEnd Sub23.显示动态时间（1）插入窗体Userform1及Label1并在窗体声明中插入Option ExplicitPublic nextRun As Date（2）在窗体Activate事件中插入Showtime（3）在窗体QueryClose事件中插入Application.OnTime nextRun, "showtime", schedule:=False （4）插入模块Module1并输入Option ExplicitSub showtime()bel1 = NowUserForm1.RepaintDoEventsUserForm1.nextRun = Now + 1 / 86400Application.OnTime UserForm1.nextRun, "showtime" End Sub24.加载Combobox1选项ComboBox1.AddItem "收入型"ComboBox1.Additem “支出型”25.使Textbox1自动程输入状态显示(有光标闪动)TextBox1.SetFocus26.打开C盘目录Shell "explorer.exe C:\", 1。