下载文档原格式
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单元格的字体为粗体、背景色为红色、边框为实线。
前言我们平时在工作表单元格的公式中常常使用函数，Excel自带的常用的函数多达300多个, 功能强大，丰富多彩，但是在VBA中不能直接应用，必须在函数名前面加上对象，比如: Application.WorksheetF unction .Sum(argl,arg2,arg3)o而能在VBA中直接应用的函数也有儿十个，下面将逐一详细介绍常用的40个VBA函数, 以供大家学习参考。
第1.1例ASC函数一、题目：要求编写一段代码，运行后得到字符串” Excel”的首字母和” e”的ASCII值。
二、代码：Sub 示例—1_01()Dim myNuml%, myNum2%myNuml 二Asc("Exce门’返回69myNum2 二Asc("e")'返回101[al]二"myNuml二n: [bl] = myNuml[a2] = "myNum2= ": [b2] = myNum2End Sub三、代码详解1、S ub示例_1_010：宏程序的开始语句。
2、D im myNuml%, myNum2%：变量myNuml 和myNum2 声明为整型变量。
也可以写为Dim myNuml As Integer <> Integer变量存储为16位(2个字节)的数值形式，其范围为-32,768到32,767之间。
Integer的类型声明字符是白分比符号(％)。
3、m yNuml = Asc("Excel")：把Asc 函数的值赋给变量myNuml»Asc函数返回一个Integer,代表字符串中首字母的字符的ASCD代码。
语法Asc(string)必要的string (字符串)参数可以是任何有效的字符串表达式。
如果string中没有包含任何字符，则会产生运行时错误。
4、m yNum2 = Asc("e")：把Asc函数的值赋给变量myNum2。
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自带的常用的函数多达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。
ExcelVBA编程的常用代码Excel VBA编程的常用代码用过VB的人都应该知道如何声明变量，在VBA中声明变量和VB 中是完全一样的！使用Dim语句Dim a as integer '声明a为整型变量Dim a '声明a为变体变量Dim a as string '声明a为字符串变量Dim a as currency ,b as currency ,c as currency '声明a,b,c为货币变量......声明变量可以是：Byte、Boolean、Integer、Long、Currency、Single、Double、Decimal （当前不支持）、Date、String（只限变长字符串）、String * length（定长字符串）、Object、Variant、用户定义类型或对象类型。
强制声明变量Option Explicit说明：该语句必在任何过程之前出现在模块中。
声明常数用来代替文字值。
Const' 常数的默认状态是Private。
Const My = 456' 声明Public 常数。
Public Const MyString = "HELP"' 声明Private Integer 常数。
Private Const MyInt As Integer = 5' 在同一行里声明多个常数。
Const MyStr = "Hello", MyDouble As Double = 3.4567选择当前单元格所在区域在EXCEL97中，有一个十分好的功能，他就是把鼠标放置在一个有效数据单元格中，执行该段代码，你就可以将连在一起的一片数据全部选中。
只要将该段代码加入到你的模块中。
Sub My_SelectSelection.CurrentRegion.SelectEnd sub返回当前单元格中数据删除前后空格后的值sub my_trimmsgbox Trim(ActiveCell.Value)end sub单元格位移sub my_offsetActiveCell.Offset(0, 1).Select'当前单元格向左移动一格ActiveCell.Offset(0, -1).Select'当前单元格向右移动一格ActiveCell.Offset(1 , 0).Select'当前单元格向下移动一格ActiveCell.Offset(-1 , 0).Select'当前单元格向上移动一格end sub如果上述程序产生错误那是因为单元格不能移动，为了解除上述错误，我们可以往sub my_offset 之下加一段代码on error resume next注意以下代码都不再添加sub “代码名称” 和end sub请自己添加!给当前单元格赋值ActiveCell.Value = "你好"给指定单元格赋值例如：Ａ１单元格内容设为"ＨＥＬＬＯ"Range("a1").value="hello"又如：你现在的工作簿在sheet1上，你要往sheet2的Ａ１单元格中插入"ＨＥＬＬＯ"1.sheets("sheet2").selectrange("a1").value="hello"或2.Sheets("sheet1").Range("a1").Value = "hello"说明：1.sheet2被选中，然后在将“HELLO"赋到A1单元格中。
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。
删除B列中字符串数值少于21的单元格所在的行Sub 删除行()r = Range("B65536").End(xlUp).Row '行数For h = r To 1 Step -1If Cells(h, 2) < 21 Then Cells(h, 2).EntireRow.DeleteNextEnd Sub-------------------------【工作表合并】将同一工作簿中的所有工作表合并到一个工作表中新建一个工作表，写入代码[在新建的工作表标签处右键查看代码（找不到的直接按一下alt+F11) 把下面的代码复制进去然后点上面的运行运行子程序即可]：Sub 合并当前工作簿下的所有工作表()Application.ScreenUpdating = FalseFor j = 1 To Sheets.CountIf Sheets(j).Name <> ThenX = Range("A65536").End(xlUp).Row + 1Sheets(j).UsedRange.Copy Cells(X, 1)End IfNextRange("B1").SelectApplication.ScreenUpdating = TrueMsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"End Sub*********************************************************代码这样写也行：Sub c()For i = Sheets.Count To 2 Step -1Sheets(i).SelectSheets(i).UsedRange.CopySheets(1).SelectCells(Cells(65000, 1).End(xlUp).Row + 1, 1).SelectActiveSheet.Paste'Sheets(i).DeleteNext iEnd Sub************************************************************把一个工作簿中的所有表单合并成一个表单，怎么去掉重复的表头、标题行？方法如下：Sub c()For i = Sheets.Count To 2 Step -1Sheets(i).UsedRange.Offset(1).Copy Sheets(1).Cells(65536, 1).End(xlUp).Offset(1)Next iEnd Sub说明：函数OFFSET(reference,rows,cols,height,width)以指定的引用为参照系，通过给定偏移量得到新的引用。
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。
Excel VBA编程常用代码时间:2009-12-0522:36:04来源:本站作者:未知我要投稿我要收藏投稿指南用过VB的人都应该知道如何声明变量，在VBA中声明变量和VB中是完全一样的！使用Dim语句Dim a as integer'声明a为整型变量Dim a'声明a为变体变量Dim a as string'声明a为字符串变量Dim a as currency,b as currency,c as currency'声明a,b,c为货币变量......声明变量可以是：Byte、Boolean、Integer、Long、Currency、Single、Double、Decimal（当前不支持）、Date、String（只限变长字符串）、String*length （定长字符串）、Object、Variant、用户定义类型或对象类型。
强制声明变量Option Explicit说明：该语句必在任何过程之前出现在模块中。
声明常数用来代替文字值。
Const'常数的默认状态是Private。
Const My=456'声明Public常数。
Public Const MyString="HELP"'声明Private Integer常数。
Private Const MyInt As Integer=5'在同一行里声明多个常数。
Const MyStr="Hello",MyDouble As Double=3.4567选择当前单元格所在区域在EXCEL97中，有一个十分好的功能，他就是把鼠标放置在一个有效数据单元格中，执行该段代码，你就可以将连在一起的一片数据全部选中。
只要将该段代码加入到你的模块中。
Sub My_SelectSelection.CurrentRegion.SelectEnd sub返回当前单元格中数据删除前后空格后的值sub my_trimmsgbox Trim(ActiveCell.Value)end sub单元格位移sub my_offsetActiveCell.Offset(0,1).Select'当前单元格向左移动一格ActiveCell.Offset(0,-1).Select'当前单元格向右移动一格ActiveCell.Offset(1,0).Select'当前单元格向下移动一格ActiveCell.Offset(-1,0).Select'当前单元格向上移动一格end sub如果上述程序产生错误那是因为单元格不能移动，为了解除上述错误，我们可以往sub my_offset之下加一段代码on error resume next注意以下代码都不再添加sub“代码名称”和end sub请自己添加!给当前单元格赋值ActiveCell.Value="你好！！！"给指定单元格赋值例如：Ａ１单元格内容设为"ＨＥＬＬＯ"Range("a1").value="hello"又如：你现在的工作簿在sheet1上，你要往sheet2的Ａ１单元格中插入"ＨＥＬＬＯ"1.sheets("sheet2").selectrange("a1").value="hello"或2.Sheets("sheet1").Range("a1").Value="hello"说明：1.sheet2被选中，然后在将“HELLO"赋到A1单元格中。
2.sheet2不必被选中，即可“HELLO"赋到sheet2的A1单元格中。
隐藏工作表'隐藏SHEET1这张工作表sheets("sheet1").Visible=False'显示SHEET1这张工作表sheets("sheet1").Visible=True打印预览有时候我们想把所有的EXCEL中的SHEET都打印预览，请使用该段代码，它将在你现有的工作簿中循环，直到最后一个工作簿结束循环预览。
Dim my As WorksheetFor Each my In Worksheetsmy.PrintPreviewNext my得到当前单元格的地址msgbox ActiveCell.Address得到当前日期及时间msgbox date&chr(13)&time保护工作簿ActiveSheet.Protect取消保护工作簿ActiveSheet.Unprotect给活动工作表改名为"liu"="liu"打开一个应用程序AppActivate(Shell("C:WINDOWSCALC.EXE"))增加一个工作表Worksheets.Add删除活动工作表activesheet.delete打开一个工作簿文件Workbooks.Open FileName:="C:My DocumentsBook2.xls"关闭活动窗口ActiveWindow.Close单元格格式选定单元格左对齐Selection.HorizontalAlignment=xlLeft选定单元格居中Selection.HorizontalAlignment=xlCenter选定单元格右对齐Selection.HorizontalAlignment=xlRight选定单元格为百分号风格Selection.Style="Percent"选定单元格字体为粗体Selection.Font.Bold=True选定单元格字体为斜体Selection.Font.Italic=True选定单元格字体为宋体20号字With Selection.Font.Name="宋体".Size=20End WithWith语句With对象.描述End With清除单元格ActiveCell.Clear'删除所有文字、批注、格式返回选定区域的行数MsgBox Selection.Rows.Count返回选定区域的列数MsgBox Selection.Columns.Count返回选定区域的地址Selection.Address忽略所有的错误ON ERROR RESUME NEXT遇错跳转on error goto err_handle'中间的其他代码err_handle:'标签'跳转后的代码删除一个文件kill"c:1.txt"定制自己的状态栏Application.StatusBar="现在时刻:"&Time恢复自己的状态栏Application.StatusBar=false用代码执行一个宏Application.Run macro:="text"滚动窗口到a1的位置ActiveWindow.ScrollRow=1ActiveWindow.ScrollColumn=1定制系统日期Dim MyDate,MyDayMyDate=#12/12/69#MyDay=Day(MyDate)返回当天的时间Dim MyDate,MyYearMyDate=DateMyYear=Year(MyDate)MsgBox MyYearinputbox<输入框>XX=InputBox("Enter number of months to add")得到一个文件名Dim kk As Stringkk=Application.GetOpenFilename("EXCEL(*.XLS),*.XLS",Title:="提示：请打开一个EXCEL文件：")msgbox kk打开zoom对话框Application.Dialogs(xlDialogZoom).Show激活字体对话框Application.Dialogs(xlDialogActiveCellFont).Show打开另存对话框Dim kk As Stringkk=Application.GetSaveAsFilename("excel(*.xls),*.xls") Workbooks.Open kk1excle快捷键大全对工具栏进行操作的快捷键激活菜单栏，F10，Alt选定前一个或下一个工具栏，Ctrl+Tab或Ctrl+Shift+Tab选定工具栏中的下一个或前一个按钮或菜单，Tab或Shift+Tab(当某个工具栏被激活时)打开选定的菜单，Enter运行选按钮的操作，Enter在选定的文本框中输入文本，Enter在对话框中使用的快捷键取消当前任务,Esc单击相应命令，Alt+下划线字母单击选定的按钮,Enter在选项中前移，Tab在选项后移,Shift+Tab在选项卡中前移,Ctrl+Tab在选项卡中后移,Ctrl+Shift+Tab刷新“另存为”或“打开”对话框,F5插入、删除和复制选定区域的快捷键复制选定区域，Ctrl+C粘贴选定区域,Ctrl+V剪切选定区域,Ctrl+X清除选定区域的内容，Delete插入空白单元格,Ctrl+Shift+加号删除选定区域,Ctrl+-撤消最后一次操作,Ctrl+Z使用“office助手”需要用到的快捷键关闭“office助手”提供的消息,Esc通过“office助手”获取帮助信息,F1显示下一项提示,Alt+N显示前一项提示,Alt+B在向导中显示或隐藏“office助手”,空格键对窗口进行操作的快捷键切换到下一个程序,Alt+Tab切换到前一个程序,Alt+Shift+Tab显示windwos“开始”菜单,Ctrl+Esc关闭活动工作薄窗口,Ctrl+W恢复活动工作薄窗口,Ctrl+F5切换到下一个工作薄窗口，Ctrl+F6切换到前一个工作薄窗口,Ctrl+Shift+F6执行“移动”命令(菜单栏中的工作薄图标菜单),Ctrl+F7运行“大小”命令(菜单栏中的工作薄图标菜单),Ctrl+F8将工作薄窗口最小化为图标,Ctrl+F9最大化或恢复工作薄窗口,Ctrl+F10在“打开”或“另存为”对话框中更新可见的文件,F5使用对话框进行操作的快捷键切换到对话框中的下一个选项卡,Ctrl+Tab或Ctrl+PageDown切换到对话框中的前一个选项卡,Ctrl+Shift+Tab或Ctrl+PageUp移动到下一个选项或选项组,Tab移动到前一个选项或选项组,Shift+Tab在活动下拉列表框的选项间移动，或在选项组选项间移动,方向键招待活动按钮的操作，或选定或清除当前复选框,空格键取消命令或关闭对话框,Esc在文本框中进行操作的快捷键移动到内容的开始,Home移动到内容的最后,End向左或向右移动一个字符,左右方向键向左或向右移动一个字,Ctrl+左右方向键选定从插入点到开始的输入内容，Shift+Home选定从插入点到最后的输入内容，Shift+End选定或取消左面的一个字符,Shift+左方向键选定或取消右面的一个字符，Shift+右方向键选定或取消左面的一个字,Ctrl+Shift+左方向键选定或取消右面的一个字,Ctrl+Shift+右方向键在工作表和工作薄中选定单元格、列、行或对象的快捷键选定当前单元格周围的区域,Ctrl+Shift+*(星号)将选定区域扩展一个单元格宽度,Shift+方向键将选定区域扩展到与活动单元格同一行或同一列的最后一个非空白单元格,Ctrl+Shift+方向键将选定区域扩展到行首,Shift+Home将选定区域扩展到工作表的开始,Ctrl+Shift+Home将选定区域扩展到工作表的最后一个包含数据的单元格,Ctrl+Shift+End 选定整列，Ctrl+空格键选定整行,Shift+空格键选定整个工作表,Ctrl+A若已选定多个单元格，则只选定其中的活动单元格,Shift+Backspace将选定区域向下扩展一屏,Shift+PageDown将选定区域向上扩展一屏,Shift+PageUp在选定一个对象时，选定工作表上的所有对象,Ctrl+Shift+空格键在隐藏对象、显示对象与对象占位符之间切换，Ctrl+6显示或隐藏“常用”工具栏,Ctrl+7分级显示数据的快捷键取消行或列分组,Alt+Shift+左方向键对行或列分组,Alt+Shift+右方向键显示或隐藏分级显示符号,Ctrl+8隐藏选定行,Ctrl+9取消隐藏选定行,Ctrl+Shift+(隐藏选定列,Ctrl+0取消隐藏选定列,Ctrl+Shift+)编辑单元格的快捷键完成单元格输入,Enter取消单元格输入，Esc重复单元格一次操作,F4或Ctrl+Y在单元格中折行,Alt+Enter删除插入点左边的字符或删除选定区域,Backspace删除插入点右边的字符或删除选定区域,Delete向上下左右移动一个字符,方向键移到行首,Home移到行尾,End编辑单元格批注,Shift+F2由行或列标志创建名称,Ctrl+Shift+F3向下填充,Ctrl+D向右填充,Ctrl+R用当前输入项填充选定的单元格区域,Ctrl+Enter完成单元格输入并在选定区域中下移,Enter完成单元格输入并在选定区域中上移,Shift+Enter完成单元格输入并在选定区域中右移,Tab完成单元格输入并在选定区域中左移,Shift+Tab在单元格或编辑栏中使用的快捷键键入公式,=(等号)取消单元格或编辑栏中的输入项,Esc编辑当前单元格,F2编辑活动单元格并清除其内容，或在编辑时删除前一个字符，Backspace将名称粘贴到公式中,F3定义名称,Ctrl+F3计算所有打开工作薄中的所有工作表,F9计算活动工作表,Shift+F9输入“自动求和”公式,Alt+=(等号)输入日期,Ctrl+;输入时间,Ctrl+Shift+:插入超级链接,Ctrl+K完成单元格输入,Enter将当前单元格上方单元格中的数值复制到当前单元格或编辑栏,Ctrl+Shift+(双引号)将当前单元格上方单元格中的公式复制到当前单元格或编辑栏，Ctrl+'(单引号)在显示单元格值与单元格公式间转换,Ctrl+`(撇号)输入数组公式,Ctrl+Shift+Enter键入有效函数名后，显示公式选项板,Ctrl+A键入有效函数名后，为该函数插入变量名和括号,Ctrl+Shift+A显示“记忆式键入”列表,Ctrl+下方向键快捷键与数据格式设置显示“样式”命令,Alt+'(单引号)显示“单元格”命令,Ctrl+1应用常规数字格式,Ctrl+Shift+~应用带两个小数位的“贷币”格式,Ctrl+Shift+$应用不带小数位的“百分比”格式,Ctrl+shift+%应用带两个小数位的“科学记数”数字格式,,Ctrl+shift+^应用年月日“日期”格式,Ctrl+shift+#应用小时和分钟“时间”格式，并表明上午或下午,Ctrl+shift+@应用外边框,Ctrl+shift+&取消选定单元格区域中的所有边框,Ctrl+shift+_应用或取消字体加粗格式,Ctrl+B应用或取消字体倾斜格式,Ctrl+I应用或取消字体下划线格式,Ctrl+U应用或取消删除线格式,Ctrl+5隐藏行,Ctrl+9取消隐藏行,Ctrl+Shift+(隐藏列,Ctrl+0取消隐藏列,Ctrl+Shift+)使用Excel2003工作表的VBA示例适用范围：Microsoft Office Excel2003摘要：寻找能够为Excel工作表增加额外功能的宏。
