vba代码汇总
VBA常用代码大全
.、八、-刖言我们平时在工作表单元格的公式中常常使用函数，EGcel自带的常用的函数多达300多个, 功能强大，丰富多彩，但是在 VBA中不能直接应用，必须在函数名前面加上对象，比如：Applicatio n. WorksheetF un ctio n.Sum(arg1,arg2,arg3) 。
而能在VBA中直接应用的函数也有几十个，下面将逐一详细介绍常用的40个VBA函数, 以供大家学习参考。
第1.1例ASC函数一、题目：要求编写一段代码，运行后得到字符串”EGcel”的首字母和” e”的ASCII值。
二、代码：Sub 示例_1_01()DimmyNum1%,myNum2%myNum仁Asc("EGcel")'返回 69myNum2=Asc("e")' 返回 101[a1]="myNum 1=":[b1]=myNum1[a2]="myNum2=":[b2]=myNum2En dSub三、代码详解1、Sub示例_1_01():宏程序的开始语句。
2、DimmyNum1%,myNum2% :变量 myNum1 和 myNum2 声明为整型变量。
也可以写为DimmyNum1AsInteger 。
Integer变量存储为16位(2个字节)的数值形式，其范围为-32,768到32,767之间。
Integer的类型声明字符是百分比符号(％)。
3、myNum1=Asc("EGcel"):把 Asc 函数的值赋给变量 myNum1 。
Asc函数返回一个Integer，代表字符串中首字母的字符的 ASCII代码。
语法Asc(stri ng)必要的string (字符串)参数可以是任何有效的字符串表达式。
如果string中没有包含任何字符，则会产生运行时错误。
4、myNum2=Asc("e"):把Asc函数的值赋给变量myNum2。
VBA 中的数据计数和汇总方法
VBA 中的数据计数和汇总方法在VBA中，数据计数和汇总是一项常见且重要的任务。
通过使用适当的VBA 函数和技巧，可以轻松地对数据进行计数和汇总，从而提供有用的统计信息。
本文将介绍一些常用的VBA数据计数和汇总方法，帮助读者更好地应对这一任务的挑战。
首先，值得注意的是，在进行数据计数和汇总之前，需要确保已经将数据导入VBA工作表。
可以使用以下代码将数据从Excel工作表导入到VBA：```vbaDim dataRange As RangeSet dataRange = Sheets("Sheet1").Range("A1:D10") '将数据范围定义为工作表Sheet1的A1到D10单元格范围Dim dataArr As VariantdataArr = dataRange.Value '将数据范围的值赋给一个变量，这样可以在VBA中更方便地操作数据```接下来，我们将介绍一些常用的数据计数方法。
1. 计数非空单元格要计算数据范围中非空单元格的数量，可以使用`CountA`函数。
下面是一个示例：```vbaDim nonEmptyCount As LongnonEmptyCount = Application.WorksheetFunction.CountA(dataRange)```2. 计数满足特定条件的单元格如果只想计算数据范围中满足特定条件的单元格数量，可以使用`CountIf`函数。
例如，要计算数值列中大于10的单元格数量，可以使用以下代码：```vbaDim conditionCount As LongconditionCount = Application.WorksheetFunction.CountIf(dataRange.Columns(1), " > 10")```以上代码将仅计算第一列中数值大于10的单元格数量。
vba 常用宏代码
在VBA中，你可以使用宏来自动执行一系列的操作。
以下是一些常用的VBA宏代码示例：1.打开一个工作簿：vba复制代码Sub OpenWorkbook()Workbooks.Open "C:\path\to\your\workbook.xlsx"End Sub2.关闭一个工作簿：vba复制代码Sub CloseWorkbook()ThisWorkbook.Close SaveChanges:=TrueEnd Sub3.复制一个单元格的内容：vba复制代码Sub CopyCell()Range("A1").Copy Range("B1")End Sub4.粘贴一个单元格的内容：vba复制代码Sub PasteCell()Range("B1").PasteSpecial Paste:=xlPasteValuesEnd Sub5.查找并替换单元格中的内容：vba复制代码Sub FindAndReplace()Range("A1").Replace What:="old", Replacement:="new"End Sub6.自动填充数据：vba复制代码Sub AutoFill()Range("A1:A10").FillDownEnd Sub7.插入新的列或行：vba复制代码Sub InsertColumn()Columns("B:B").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAboveEnd Sub8.删除列或行：vba复制代码Sub DeleteColumn()Columns("B:B").Delete Shift:=xlToLeft,CopyOrigin:=xlFormatFromLeftOrAboveEnd Sub。
vba编程代码大全
vba编程代码大全VBA编程代码大全。
VBA是Visual Basic for Applications的缩写，是一种用于Microsoft Office应用程序的编程语言。
通过VBA，用户可以编写自定义的宏和程序，以实现自动化操作和定制功能。
VBA编程在Excel、Word、PowerPoint等Office应用中都有广泛的应用，可以大大提高工作效率和数据处理的灵活性。
本文将为大家详细介绍VBA 编程中常用的代码，帮助大家更好地掌握VBA编程技能。
一、基本操作。
1. 打开VBA编辑器。
在Office应用程序中，按下Alt + F11快捷键即可打开VBA编辑器。
在VBA 编辑器中，可以编写和管理VBA代码。
2. 编写子程序。
使用Sub关键字定义一个子程序，然后在其中编写具体的VBA代码。
例如：Sub HelloWorld()。
MsgBox "Hello, World!"End Sub。
3. 运行宏。
在VBA编辑器中，可以直接运行编写好的宏程序。
也可以在Office应用程序中，通过快捷键或菜单来运行宏。
二、常用代码。
1. 操作单元格。
在Excel中，可以使用VBA来操作单元格，例如：Range("A1").Value = 100。
Range("A1").Interior.Color = RGB(255, 0, 0)。
2. 循环结构。
使用VBA可以编写各种类型的循环结构，例如For循环、Do While循环等，来实现对数据的遍历和处理。
3. 条件判断。
VBA中的If语句可以用来进行条件判断，根据不同的条件执行不同的操作，例如：If Range("A1").Value > 0 Then。
Range("B1").Value = "Positive"Else。
Range("B1").Value = "Negative"End If。
VBA代码收集整理
开始-打印机和传真机-右健该打印机图标-打印首选项-灰度打印或黑色打印前面加勾就可以了. Private Sub 添加_Click()If 员工编号.Value = "" Or 姓名= "" Then Exit SubDim A As RangeSet A = Sheets("员工信息").Cells.Find(员工编号)If Not A Is Nothing ThenMsgBox "已存在该编号记录"Exit SubEnd If'***********************************On Error Resume NextDim x As Integer, Y As IntegerDim Mrng As RangeWith Sheets("员工信息")Y = .Range("A65536").End(xlUp).Row + 1For x = 1 To Me.Controls.CountSet Mrng = .Cells.Find(Me.Controls(x).Name).Cells(Y, Mrng.Column) = Me.Controls(x).TextNext xEnd WithMsgBox "添加成功", 64Set Mrng = Nothing清空所有内容End SubPrivate Sub 修改_Click()On Error Resume NextDim x As Integer, Y As IntegerDim Mrng As RangeIf 姓名= "" Then Exit SubWith Sheets("员工信息")Y = .Cells.Find(员工编号).RowFor x = 1 To Me.Controls.CountSet Mrng = .Cells.Find(Me.Controls(x).Name).Cells(Y, Mrng.Column) = Me.Controls(x).TextNext xEnd WithMsgBox "修改成功", 64Set Mrng = NothingEnd SubPrivate Sub 退出_Click()Unload MeEnd Sub…自动找到活动工作簿的路径并生成模板Function FileOpened(BName) As BooleanOn Error Resume NextIf Len(Workbooks(BName).Name) > 0 ThenIf Err.Number = 9 ThenFileOpened = FalseElseFileOpened = TrueEnd IfEnd IfEnd FunctionFunction FileExist(FName) As BooleanDim x As Stringx = Dir(FName)If x <> "" ThenFileExist = TrueElseFileExist = FalseEnd IfEnd FunctionSub 自动生成模板()Dim OpenFName$, FileSource$OpenFName = "模板.xls"FileSource = ActiveWorkbook.PathIf FileOpened(OpenFName) ThenMsgBox OpenFName & " is opened!"ElseIf FileExist(FileSource & OpenFName) ThenWorkbooks.Open FileSource & OpenFNameElseActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & "模板.xls"End IfEnd IfEnd Sub…在当前E4单元格自动生成本月第一天的日期和日期格式“yyyy””-“”mm””-“”dd”Sub 自动生成本月日期()Range("E4").SelectSelection.NumberFormatLocal = "d"[E4] = Now() - Day(Now()) + 1Sub 插入多个工作表并命名()On Error GoTo 100Dim i As IntegerFor i = 12 To 1 Step -1 = i & "月"Next i100:Exit SubEnd SubSub 复制到所有工作表()On Error Resume NextDim wth As IntegerSheets("模板").Rows.SelectFor wth = Sheets.Count To 1 Step -1'复制源文件中第一个工作表的内容Sheets("模板").Rows.CopySheets(wth).Range("A1").SelectThisWorkbook.Sheets(wth).PasteNext wthEnd Sub窗体代码集：1. CommandButton1控件单击事件，寻找活动工作表中与窗体控件的名称相同的单元格确定其行数，把窗体控件的值累加上所要找的单元格的值，并相加的和返给指定的单元格。
vba编程代码大全
vba编程代码大全VBA编程代码大全。
VBA（Visual Basic for Applications）是一种用于应用程序开发的编程语言，它可以帮助用户在Microsoft Office软件中自动化任务，提高工作效率。
在本文中，我们将为您介绍一些常用的VBA编程代码，帮助您更好地利用VBA来处理各种任务。
首先，让我们来看一些常用的VBA基础操作代码。
在VBA中，您可以使用MsgBox函数来显示消息框，例如：```vba。
MsgBox "Hello, World!"```。
这段代码将会在屏幕上显示一个包含"Hello, World!"的消息框。
除了MsgBox 函数，VBA还提供了InputBox函数来获取用户输入的数值或文本：```vba。
Dim userInput As String。
userInput = InputBox("Please enter your name:")。
```。
这段代码将会弹出一个输入框，等待用户输入姓名，并将用户输入的内容存储在userInput变量中。
接下来，让我们来看一些与Excel相关的VBA代码。
在Excel中，VBA可以帮助您自动化各种数据处理任务。
例如，您可以使用VBA来创建新的工作表，并向其中填充数据：```vba。
Dim ws As Worksheet。
Set ws = ThisWorkbook.Sheets.Add。
= "NewSheet"ws.Range("A1").Value = "Hello"```。
这段代码将会在当前工作簿中创建一个名为"NewSheet"的新工作表，并在A1单元格中填入"Hello"。
除了操作工作表，VBA还可以帮助您处理Excel中的图表。
例如，您可以使用VBA来创建新的图表，并向其中添加数据：```vba。
vba常用代码大全
前言我们平时在工作表xx的公式xx常常使用函数，Excel自带的常用的函数多达300多个，功能强大，丰富多彩，但是在VBAxx不能直接应用，必须在函数名前面加上对象，比如：Application.WorksheetFunction.Sum(arg1,arg2,arg3)。
而能在VBAxx直接应用的函数也有几十个，下面将逐一详细介绍常用的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。
vba常用代码大全
前言我们平时在工作表单元格的公式中常常使用函数，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。
(word完整版)VBA代码汇总,推荐文档
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方法可以指定某一个单元格为活动单元格。
VBA精华代码50例
1 建立窗口的复本1.Sub 建立窗口的副本()2. MsgBox “以使用中窗口为来源建立一个新的窗口副本”3. ActiveWindow.NewWindow4.End Sub2选取窗口1.Sub 选取窗口()2. MsgBox “依序切换已开启的窗口”3. wsuu = Windows.Count4. For i = 1 To wsuu5. Windows(i).Activate6. henji = MsgBox(“第 ” & i & “个窗口，还要继续吗？”, vbYesNo)7. If henji = vbNo Then Exit Sub8. Next i9.End Sub3 关闭窗口1.Sub 关闭窗口()2. MsgBox “关闭使用中的窗口”3. ActiveWindow.Close4.End Sub4 显示窗口的标题1.Sub 显示窗口的标题()2. MsgBox “显示使用中窗口的标题”3. MsgBox ActiveWindow.Caption4.End Sub5取得窗口的数量1.Sub 取得窗口的数量()2. MsgBox “显示目前已开启的窗口数量”3. MsgBox Windows.Count4.End Sub6 分割窗口与解除分割窗口1.Sub 分割窗口()2. MsgBox “以使用中储存格为基准点来分割窗口”3. gyou = ActiveCell.Row4. retu = ActiveCell.Column5. With ActiveWindow6. .SplitColumn = retu7. .SplitRow = gyou8. End With9. MsgBox “回复原来的状态”10. ActiveWindow.Split = False11.End Sub7 冻结窗格1.Sub 冻解窗格()2. MsgBox “以使用中的储存格为基准将窗格冻结”3. ActiveWindow.FreezePanes = True4.End Sub5.Sub 取消冻结窗格()6. MsgBox “取消冻结的窗格”7. ActiveWindow.FreezePanes = False8.End Sub8 移动窗口的位置1.Sub 设定窗口的位置()2. MsgBox “将使用中窗口向下移动60点、向右移动90点”3. jyoutan = ActiveWindow.Top4. satan = ActiveWindow.Left5. ActiveWindow.Top = jyoutan + 606. ActiveWindow.Left = satan + 907. MsgBox “回复原来的状态”8. ActiveWindow.Top = jyoutan9. ActiveWindow.Left = satan10.End Sub9 变更窗口的高度及宽度1.Sub 变更窗口的高度及宽度()2. MsgBox “将使用中窗口的高度及宽度各缩减一半”3. takasa = ActiveWindow.Height4. haba = ActiveWindow.Width5. ActiveWindow.Height = takasa / 26. ActiveWindow.Width = haba / 27. MsgBox “回复原来的状态”8. ActiveWindow.Height = takasa9. ActiveWindow.Width = haba10.End Sub10 锁定窗口的尺寸1.Sub 窗口尺寸的变更()2. MsgBox “锁定/解除窗口尺寸变更的功能”3. ActiveWindow.EnableResize = Not (ActiveWindow.EnableResize)4.End Sub11 变更窗口网格线的颜色1.Sub 设定窗口的网格线颜色()2. MsgBox “将窗口的网格线颜色变更为红色”3. iro = ActiveWindow.GridlineColor4. ActiveWindow.GridlineColor = RGB(255,0,0)5. MsgBox “回复原来的状态”6. ActiveWindow.GridlineColor = iro7.End Sub12 重排窗口1.Sub 重排窗口()2. MsgBox "将目前所有开启的窗口以阶梯式并排的方式来排列"3. Windows.Arrange arrangestyle:=xlArrangeStyleCascade4.End Sub5.Sub 重排窗口()6. MsgBox "将目前所有开启的窗口以砖块式并排的方式来排列"7. MsgBox "目前开启的窗口数量：" & Windows.Count8. Application.Windows.Arrange arrangestyle:=xlArrangeStyleTiled9.End Sub13 窗口的最大化及最小化1.Sub 设定窗口的状态()2. MsgBox “将使用中窗口变为最小化”3. Windows(1).WindowState = xlMinimized4. MsgBox “将使用中窗口变为最大化”5. Windows(1).WindowState = xlMaximized6.End Sub14 隐藏最大化及最小化的按钮1.Sub 隐藏最大化及最小化的按钮()2. MsgBox “隐藏窗口中最大化及最小化的按钮”3. ActiveWindow.EnableResize = Not (ActiveWindow.EnableResize)4. MsgBox “回复原来的状态”5. ActiveWindow.EnableResize = True6.End Sub15 将最上层的窗口移到最下层1.Sub 将窗口移到最下层()2. MsgBox “将使用中的窗口移到最下层”3. ActiveWindow.ActivateNext4.End Sub16 将最下层的窗口移到最上层1.Sub 将窗口移到最上层()2. MsgBox “将最下层的窗口移到最上层”3. ActiveWindow.ActivatePrevious4.End Sub17 显示储存格内的表达式1.Sub 显示表达式()2. MsgBox “在使用中窗口内，让有表达式的储存格显示表达式”3. ActiveWindow.DisplayFormulas = True4. MsgBox “回复原来的状态”5. ActiveWindow.DisplayFormulas = False6.End Sub18 显示或隐藏零值1.Sub 显示或隐藏零值()2. MsgBox “显示/隐藏使用中窗口内的零值”3. ActiveWindow.DisplayZeros = Not (ActiveWindow.DisplayZeros)4.End Sub19 显示及隐藏网格线1.Sub 显示或隐藏网格线()2. MsgBox “显示/隐藏使用中窗口的网格线”3. ActiveWindow.DisplayGridlines = Not (ActiveWindow.DisplayGridlines)4.End Sub20 以列或行为单位卷动窗口内容1.Sub 列的卷动()2. MsgBox “将窗口画面向下卷动五列”3. gyou = 54. ActiveWindow.SmallScroll Down:=gyou5.End Sub6.Sub 行的卷动()7. MsgBox “将窗口画面向右卷动两行”8. retu = 29. ActiveWindow.SmallScroll ToRight:=retu10.End Sub21 以页为单位卷动窗口内容1.Sub 页的卷动()2. MsgBox “将窗口画面向下卷动一页”3. pge = 14. rgeScroll Down:=pge5.End Sub22 显示、隐藏水平滚动条及垂直滚动条1.Sub 隐藏窗口的滚动条()2. MsgBox “隐藏/显示使用中窗口的滚动条”3. ActiveWindow.DisplayHorizontalScrollBar = Not(ActiveWindow.DisplayHorizontalScrollBar)4. ActiveWindow.DisplayVerticalScrollBar = Not (ActiveWindow.DisplayVerticalScrollBar)5.End Sub6.7.Sub 隐藏活页簿的滚动条()8. MsgBox “隐藏/显示活页簿的水平及垂直滚动条”9. Application.DisplayScrollBars = Not (Application.DisplayScrollBars)10.End Sub23 以指定的储存格卷动到窗口左上角1.Sub 以窗口左上角为基准的窗口画面卷动()2. MsgBox “将储存格C6卷动到窗口的左上角”3. ActiveWindow.ScrollRow = 64. ActiveWindow.ScrollColumn = 35.End Sub24以部分字段元为键来删除重复要判断这样的不重复，就是将数据范围设定为包含不重复的字段，以进阶筛选执行不选重复的纪录。
VBA代码全集模板
目录一、引用 (3)二、Worksheet_Change事件： (3)三、相乘 (5)四、相减 (6)五、高级筛选 (6)六、双击事件 (8)七．单位汇总（sumif），单条件汇总 (10)八、多条件汇总（连接、sumif） (13)九、多条件汇总、ado (15)十、对账 (16)十一、sql筛选 (20)十二、sql连接、交叉汇总 (21)十三、select语句总结 (23)十四、报表（有层次） (24)一、引用相对引用B4绝对引用$B$4混合引用$B4、B$4F4进行引用切换，$在字母前面则锁定列，在数字前面则锁定行。
二、Worksheet_Change 事件：1.在单元格中C4=VLOOKUP(B4,简码表!$B$4:$C$1000,2,FALSE)2. Worksheet_Change事件代码：Private Sub Worksheet_Change(ByVal Target As Range)On error resume nextIf Target.Row > 3 And Target.Column = 2 Theni = Target.RowCells(i, 3) = Application.WorksheetFunction.VLookup(Cells(i, 2), Sheets("简码表").Range("b4:c100"), 2, False)End IfEnd Sub备查代码：Private Sub Worksheet_Change(ByVal Target As Range)On Error Resume NextIf Target.Row > 3 And Target.Column = 5 Theni = Target.RowCells(i, 6) = Application.WorksheetFunction.VLookup(Cells(i, 5), Sheets("类款项").Range("b2:e2000"), 2, False)Cells(i, 7) = Application.WorksheetFunction.VLookup(Cells(i, 5), Sheets("类款项").Range("b2:e2000"), 3,False)Cells(i, 8) = Application.WorksheetFunction.VLookup(Cells(i, 5), Sheets("类款项").Range("b2:e2000"), 4, False)End IfEnd Sub三、相乘Sub 计算金额()Application.ScreenUpdating = FalseDim i As LongDim irow As Longirow = Range("a3").End(xldown).RowFor i = 4 To irowCells(i, 3) = Cells(i, 1) * Cells(i, 2)Next iApplication.ScreenUpdating = TrueEnd Sub四、相减Sub 相减()Application.ScreenUpdating = FalseRange("c3:c10000").ClearContentsDim i As LongDim irow As Longirow = Range("a5000").End(xlUp).RowFor i = 3 To irowCells(i, 3) = VBA.Round((Cells(i, 1) - Cells(i, 2)), 2)Next iApplication.ScreenUpdating = TrueEnd Sub五、高级筛选（工具-宏-录制新宏，宏名改成高级筛选）Sub 高级筛选()Sheets("业务").Range("A3:I10000").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=ActiveCell.Range("A1:B1"), Unique:=TrueEnd Sub六、双击事件1.插入-名称-定义（修改名称和引用位置）2．查看代码-插入-用户窗体工具箱-多页、列表框-右键属性点击page1修改caption为资产类-点击空白列表框修改rowsource 为box1依次类推3. 业务表-查看代码 Worksheet beforedoubleclickPrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Row > 3 And Target.Column = 6 ThenUserForm1.ShowSheets("初始化").Range("m3") = ActiveCellElseIf Target.Row > 3 And Target.Column = 7 ThenUserForm2.ShowEnd IfEnd Sub备查代码：Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Row > 3 And Target.Column = 6 ThenUserForm1.ShowSheets("初始化").Range("c2") = ActiveCellElseIf Target.Row > 3 And Target.Column = 7 ThenUserForm2.ShowSheets("初始化").Range("f2") = ActiveCellElseIf Target.Row > 3 And Target.Column = 8 ThenUserForm3.ShowEnd IfEnd Sub4．右键点击Userform1查看代码 Listbox1 dbclickPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox1.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox2.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox3.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox4.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox5.ListIndex, 0)Unload MeEnd Sub见上图5.插入用户窗体右键点击userform2 worksheet dblclickPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 7) = ListBox1.List(ListBox1.ListIndex, 0)Unload MeEnd SubUserform initializePrivate Sub UserForm_Initialize()Application.ScreenUpdating = FalseWith Sheets("初始化")Sheets("科目表").Range("h2:i10000").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=.Range("m2:m3"), CopyToRange:=.Range("n2"), Unique:=TrueEnd WithApplication.ScreenUpdating = TrueEnd Sub七．单位汇总（sumif），单条件汇总=SUMIF(业务!$D$4:$D$1000,单位汇总!$A15,业务!I$4:I$10000)Sub 单位汇总1()Application.ScreenUpdating = Falserange("a1:i10000").ClearCells(3, 2) = "指标数"Cells(3, 3) = "拨款数"Cells(3, 4) = "余额"Cells(1, 7) = "单位"Cells(3, 7) = "单位"Cells(3, 8) = "指标数"Cells(3, 9) = "拨款数"Sheets("业务").Range("D3:D10000").AdvancedFilter Action:=xlFilterCopy, _CopyToRange:=Range("A3"), Unique:=TrueSheets("业务").Range("A3:J10000").AdvancedFilter Action:=xlFilterCopy, _CriteriaRange:=Range("G1:G2"), CopyToRange:=Range("G3:I3"), Unique:=FalseDim i As LongDim irow As Longirow = Range("a3").End(xlDown).RowFor i = 4 To irowCells(i, 2) = Application.WorksheetFunction.SumIf(Range("g4:g10000"), Cells(i, 1), Range("h4:h10000"))Cells(i, 3) = Application.WorksheetFunction.SumIf(Range("g4:g10000"), Cells(i, 1), Range("i4:i10000"))Cells(i, 4) = VBA.Round(Cells(i, 2) - Cells(i, 3), 2)Next iRange("g1:i10000").ClearApplication.ScreenUpdating = TrueEnd Sub八、多条件汇总（连接、sumif）连接=k4&l4&m4&n4Vba：Sub 多条件汇总()Application.ScreenUpdating = FalseRange("a1:p10000").ClearSheets("业务").Range("D3:G10000").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=Range("B3:E3"), Unique:=TrueSheets("业务").Range("D3:I10000").AdvancedFilter Action:=xlFilterCopy, _CopyToRange:=Range("K3:P3"), Unique:=FalseDim j As LongDim jrow As Longjrow = Range("k3").End(xlDown).RowFor j = 4 To jrowCells(j, 10) = Cells(j, 11) & Cells(j, 12) & Cells(j, 13) & Cells(j, 14)Next jDim i As LongDim irow As Longirow = Range("b3").End(xlDown).RowFor i = 4 To irowCells(3, 6) = "指标数"Cells(3, 7) = "拨款数"Cells(3, 8) = "余额"Cells(i, 1) = Cells(i, 2) & Cells(i, 3) & Cells(i, 4) & Cells(i, 5)Cells(i, 6) = Application.WorksheetFunction.SumIf(Range("j4:j10000"), Cells(i, 1), Range("o4:o10000"))Cells(i, 7) = Application.WorksheetFunction.SumIf(Range("j4:j10000"), Cells(i, 1), Range("p4:p10000"))Cells(i, 8) = VBA.Round(Cells(i, 6) - Cells(i, 7), 2)Next iRange("i3:p10000").ClearRange("a1:a10000").DeleteApplication.ScreenUpdating = TrueEnd Sub九、多条件汇总、adoSub 多条件汇总()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类,款,项, sum(指标数) as 预算股指标,sum(拨款数) as 预算股拨款 from[业务$a3:J10000] where 归口='" & Range("h2").Value & "'and 月<=" & Range("i2").Value & " GROUP BY 单位,类,款,项"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("多条件汇总").Cells(3, i) = rst.Fields(i - 1).Name Next iSheets("多条件汇总").Range("a4").CopyFromRecordset rst rst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd Sub十、对账Sub 预算股()Application.ScreenUpdating = FalseDim i As IntegerDim strsql1 As StringDim cnn1 As New ADODB.ConnectionDim rst1 As New ADODB.Recordsetcnn1.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql1 = " SELECT 单位,类,款,项, sum(指标数) as 预算股指标 from[预算股$a3:m50000] where 归口='" & Range("h2").Value & "'and 月<=" & Range("i2").Value & " GROUP BY 单位,类,款,项" rst1.Open strsql1, cnn1For i = 1 To rst1.Fields.CountSheets("对帐").Cells(3, i + 10) = rst1.Fields(i - 1).NameNext iSheets("对帐").Range("k4").CopyFromRecordset rst1rst1.Closecnn1.CloseSet rst1 = NothingSet cnn1 = NothingDim strsql2 As StringDim cnn2 As New ADODB.ConnectionDim rst2 As New ADODB.Recordsetcnn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql2 = " SELECT 单位,类,款,项, sum(指标数) as 专业股指标 from[专业股$a3:j50000] where 归口='" & Range("h2").Value & "'and 月<=" & Range("i2").Value & " GROUP BY 单位,类,款,项" rst2.Open strsql2, cnn2For i = 1 To rst2.Fields.CountSheets("对帐").Cells(3, i + 19) = rst2.Fields(i - 1).NameNext iSheets("对帐").Range("t4").CopyFromRecordset rst2rst2.Closecnn2.CloseSet rst2 = NothingSet cnn2 = Nothings = Application.WorksheetFunction.CountA(Range("k4:k10000")) + 4Range("T4:W10000").SelectSelection.CopyRange("K" & s).SelectActiveSheet.PasteRange("X4:X10000").SelectSelection.CopyRange("P" & s).SelectActiveSheet.PasteRange("X3").SelectSelection.CopyRange("P3").SelectActiveSheet.PasteDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类,款,项, sum(预算股指标) as 预算股指标 ,sum(专业股指标) as 专业股指标 from[对帐$k3:p50000] GROUP BY 单位,类,款,项"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("对帐").Cells(3, i) = rst.Fields(i - 1).NameNext iSheets("对帐").Range("a4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd Sub十一、sql筛选Sub 筛选()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT distinct 单位,类,款,项 from[专业$a3:h10000]"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("筛选").Cells(3, i) = rst.Fields(i - 1).NameNext iSheets("筛选").Range("a4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = True End Sub十二、sql连接、交叉汇总Sub 连接()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 股,月,归口,单位,类,款,项,指标数 from [专业$a3:h10000] union ALL SELECT 股,月,归口,单位,类,款,项,指标数 from [预算$a3:l10000] order by 股 desc"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("连接").Cells(1, i + 19) = rst.Fields(i - 1).NameNext iSheets("连接").Range("t2").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd SubSub 汇总()Application.ScreenUpdating = FalseCall 连接Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " transform sum(指标数) SELECT 单位,类,款,项 from [连接$t1:aa10000] where 归口= '" & Range("h2").Value & "' and 月=" & Range("i2").Value & " group by 单位,类,款,项 pivot 股" rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("连接").Cells(3, i) = rst.Fields(i - 1).NameNext iSheets("连接").Range("a4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingRange("t1:aa10000").ClearContentsApplication.ScreenUpdating = TrueEnd Sub十三、select语句总结1、筛选（false ---筛选全部）Select 列表名称1,列表名称2,…….列表名称n from [表$区域]或者Select * from [表$区域]2、筛选唯一的数据Select distinct 列表名称1,列表名称2,…….列表名称n from [表$区域]3、分类汇总Select 列表名称1,列表名称2,…….列表名称n，sum(a) as a from [表$区域]Group by列表名称1,列表名称2,…….列表名称n4、条件分类汇总Select 列表名称1,列表名称2,…….列表名称n，sum(a) as a from [表$区域]Where 归口=’”& range(“”).value &”’ and 月=”& range(“”).value &” Group by列表名称1,列表名称2,…….列表名称n5、交叉汇总Transform sum() select 列名称1,……列名称n from[表$区域] group by 列名称1，…..列名称n pivot 交叉事项6、连接Select 列名称1，…列名称n from[表$区域] union all Select 列名称1，…列名称n from[表$区域] order by 列名称 desc十四、报表（有层次）连接Transform sum（指标数），pivot 股按单位、类、款进行汇总按单位、类进行汇总按单位进行汇总连接以上四个表的内容，并按单位、类、款、项进行排序，其中单位按降序排序1、整体写代码Sub 报表()Application.ScreenUpdating = FalseDim i As IntegerDim strsql1 As StringDim cnn1 As New ADODB.ConnectionDim rst1 As New ADODB.Recordsetcnn1.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql1 = " SELECT 股,月,归口,单位,类,款,项,sum(指标数) as 指标数 from[专业$a3:h10000] group by 股,月,归口,单位,类,款,项 union all SELECT 股,月,归口,单位,类,款,项,sum(指标数) as 指标数 from[预算$a3:l10000] group by 股,月,归口,单位,类,款,项 order by 股 desc"rst1.Open strsql1, cnn1For i = 1 To rst1.Fields.CountSheets("报表").Cells(3, i + 9) = rst1.Fields(i - 1).NameNext iSheets("报表").Range("j4").CopyFromRecordset rst1rst1.Closecnn1.CloseSet rst1 = NothingSet cnn1 = NothingDim strsql2 As StringDim cnn2 As New ADODB.ConnectionDim rst2 As New ADODB.Recordsetcnn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql2 = "transform sum(指标数) SELECT 单位,类,款,项 from[报表$j3:q10000] where 归口='" & Range("g2") _.Value & "' and 月<=" & Range("h2").Value & " group by 单位,类,款,项 order by 单位 desc pivot 股 "rst2.Open strsql2, cnn2For i = 1 To rst2.Fields.CountSheets("报表").Cells(3, i + 19) = rst2.Fields(i - 1).NameNext iSheets("报表").Range("t4").CopyFromRecordset rst2rst2.Closecnn2.CloseSet rst2 = NothingSet cnn2 = NothingDim strsql3 As StringDim cnn3 As New ADODB.ConnectionDim rst3 As New ADODB.Recordsetcnn3.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql3 = "SELECT 单位,类,款,sum(专业股) as 专业股,sum(预算股) as 预算股 from[报表$t3:y10000] group by 单位,类,款 order by 单位 desc"rst3.Open strsql3, cnn3For i = 1 To rst3.Fields.CountSheets("报表").Cells(3, i + 26) = rst3.Fields(i - 1).NameNext iSheets("报表").Range("aa4").CopyFromRecordset rst3rst3.Closecnn3.CloseSet rst3 = NothingSet cnn3 = NothingDim strsql4 As StringDim cnn4 As New ADODB.ConnectionDim rst4 As New ADODB.Recordsetcnn4.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql4 = "SELECT 单位,类,sum(专业股) as 专业股,sum(预算股) as 预算股 from[报表$t3:y10000] group by 单位,类 order by 单位 desc"rst4.Open strsql4, cnn4For i = 1 To rst4.Fields.CountSheets("报表").Cells(3, i + 32) = rst4.Fields(i - 1).NameNext iSheets("报表").Range("ag4").CopyFromRecordset rst4rst4.Closecnn4.CloseSet rst4 = NothingSet cnn4 = NothingDim strsql5 As StringDim cnn5 As New ADODB.ConnectionDim rst5 As New ADODB.Recordsetcnn5.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql5 = "SELECT 单位,sum(专业股) as 专业股,sum(预算股) as 预算股 from[报表$t3:y10000] group by 单位 order by 单位 desc"rst5.Open strsql5, cnn5For i = 1 To rst5.Fields.CountSheets("报表").Cells(3, i + 37) = rst5.Fields(i - 1).NameNext iSheets("报表").Range("al4").CopyFromRecordset rst5rst5.Closecnn5.CloseSet rst5 = NothingSet cnn5 = NothingColumns("AD:AD").SelectSelection.Insert Shift:=xlToRightRange("ad3") = "项"Columns("Aj:Ak").SelectSelection.Insert Shift:=xlToRightRange("aj3") = "款"Range("ak3") = "项"Columns("Ap:Ar").SelectSelection.Insert Shift:=xlToRightRange("ap3") = "类"Range("aq3") = "款"Range("ar3") = "项"Dim strsql6 As StringDim cnn6 As New ADODB.ConnectionDim rst6 As New ADODB.Recordsetcnn6.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql6 = " SELECT 单位,类,款,项,专业股,预算股 from [报表$t3:y10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$aa3:af10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$ah3:am10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$ao3:at10000] order by 单位 desc,类,款,项 "rst6.Open strsql6, cnn6For i = 1 To rst6.Fields.CountSheets("报表").Cells(3, i) = rst6.Fields(i - 1).NameNext iSheets("报表").Range("a4").CopyFromRecordset rst6rst6.Closecnn6.CloseSet rst6 = NothingSet cnn6 = NothingRange("j1:au10000").ClearContentsDim p As LongDim prow As Longprow = Range("a3").End(xlDown).RowFor p = 4 To prowRange("g3") = "金额"Cells(p, 7) = VBA.Round(Cells(p, 6) - Cells(p, 5), 2)Next pApplication.ScreenUpdating = TrueEnd Sub2、分开写代码：Sub 连接()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 月,归口,股,单位,类,款,项,sum(指标数) as 指标数 from[专业$a3:h10000] group by 月,归口,股,单位,类,款,项 union all SELECT 月, 归口,股,单位,类,款,项,sum(指标数) as 指标数 from[预算$a3:l10000] group by 月, 归口,股,单位,类,款,项 order by 股 desc"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 9) = rst.Fields(i - 1).NameNext iSheets("报表").Range("j4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd SubSub 项()Application.ScreenUpdating = FalseCall 连接Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';DataSource=" & ThisWorkbook.FullNamestrsql = "transform sum(指标数) SELECT 单位,类,款,项 from [报表$j3:q10000] where 归口= '" & Range("g2").Value & "' and 月<=" & Range("h2").Value & " group by 单位,类,款,项 pivot 股"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 19) = rst.Fields(i - 1).NameNext iSheets("报表").Range("t4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd SubSub 款()Application.ScreenUpdating = FalseCall 项Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类,款, sum(专业股) as 专业股, sum(预算股) as 预算股 from [报表$t3:y10000] group by 单位,类,款 "rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 26) = rst.Fields(i - 1).NameNext iSheets("报表").Range("aa4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingColumns("AD:AD").SelectSelection.Insert Shift:=xlToRightCells(3, 30) = "项"Application.ScreenUpdating = TrueEnd SubSub 类()Application.ScreenUpdating = FalseCall 款Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类, sum(专业股) as 专业股, sum(预算股) as 预算股 from [报表$aa3:af10000] group by 单位,类 "rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 33) = rst.Fields(i - 1).NameNext iSheets("报表").Range("ah4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingColumns("AJ:AJ").SelectSelection.Insert Shift:=xlToRightColumns("AK:AK").SelectSelection.Insert Shift:=xlToRightRange("AJ3").SelectActiveCell.FormulaR1C1 = "款"Range("AK3").SelectActiveCell.FormulaR1C1 = "项"Application.ScreenUpdating = TrueEnd SubSub 单位()Application.ScreenUpdating = FalseCall 类Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位, sum(专业股) as 专业股, sum(预算股) as 预算股 from [报表$ah3:am10000] group by 单位 "rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 40) = rst.Fields(i - 1).NameNext iSheets("报表").Range("ao4").CopyFromRecordset rstrst.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = True Columns("AP:AP").SelectSelection.Insert Shift:=xlToRight Columns("AQ:AQ").SelectSelection.Insert Shift:=xlToRight Columns("AR:AR").SelectSelection.Insert Shift:=xlToRight Range("AP3").SelectActiveCell.FormulaR1C1 = "类"Range("AQ3").SelectActiveCell.FormulaR1C1 = "款"Range("AR3").SelectActiveCell.FormulaR1C1 = "项" End SubSub 报表()If Range("i2") = "类" ThenCall 类ElseIf Range("i2") = "款" ThenCall 款ElseCall 项End IfEnd SubSub 总报表()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类,款,项,专业股,预算股 from [报表$t3:y10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$aa3:af10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$ah3:am10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$ao3:at10000] order by 单位 desc,类,款,项 "rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i) = rst.Fields(i - 1).NameNext iSheets("报表").Range("a4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingRange("j1:br10000").ClearApplication.ScreenUpdating = TrueEnd Sub插入图片Sub 按钮48_单击() 宏按钮名，编码时自动生成On Error Resume NextDim MR As RangeFor Each MR In SelectionIf Not IsEmpty(MR) ThenMR.SelectML = MR.LeftMT = MR.TopMW = MR.WidthMH = MR.HeightActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).SelecterPicture _End IfNextEnd Sub与EXCEL表在同一个文件夹里，。
vba常用代码大全
前言我们平时在工作表xx的公式xx常常使用函数，Excel自带的常用的函数多达300多个，功能强大，丰富多彩，但是在VBAxx不能直接应用，必须在函数名前面加上对象，比如：Application.WorksheetFunction.Sum(arg1,arg2,arg3)。
而能在VBAxx直接应用的函数也有几十个，下面将逐一详细介绍常用的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。
VBA代码汇总
Sub 批量超链接word文档()' 宏1 宏' 超链接Dim p$, f$, i As Integeri = 1p = "C:\Users\Administrator\Desktop\国创撰写\" & ""f = Dir(p & "*.docx") '取得第一个pdf文件名Do While f <> "" ' 循环语句ThisWorkbook.ActivateSheets(1).Cells(i, 1).Value = f 'Range("a1").Value = p & fActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=p & f, _TextToDisplay:=f'MsgBox p & f 显示路径加文件名f = Dir '第二个文件名i = i + 1LoopEnd SubPrivate Sub CommandButton1_Click() 随机选择器Dim a, b, c, d As StringDim shu As IntegerDim arr(1 To 4)shu = Int((4 * Rnd) + 1)arr(1) = TextBox1.Valuearr(2) = TextBox2.Valuearr(3) = TextBox3.Valuearr(4) = TextBox4.ValueMsgBox "excel推荐你今天应该吃" & arr(shu)End SubPrivate Sub CommandButton2_Click()Unload MeEnd SubSub 批量新建指定名称工作簿()Application.DisplayAlerts = FalseFor i = 1 To 54 ' 个数减一Dim Rng As StringDim abc As RangeDim wb As WorkbookDim wb1 As WorkbookSet wb1 = ThisWorkbookWith ActiveCellRng = .ValueSet abc = .Offset(1, 0)End WithDim a As RangeDim b As Longb = 0For Each a In Range("E:E")If a.Value = Rng Thenb = b + 1End IfNextActiveCell.Offset(b, 0).EntireRow.SelectSelection.Insert Shift:=xlDownSelection.Insert Shift:=xlDownabc.SelectRange("A1").EntireRow.Copy abc.Offset(b, -4)Set wb = Workbooks.Add'Filename:=ThisWorkbook.Path & Application.PathSeparator & Rng & ".xls"wb1.Sheets(1).Activateabc.CurrentRegion.Copywb.Sheets(1).Activatewb.Sheets(1).Pastewb.SaveAs "C:\Users\Administrator\Desktop\团队人员统计\" & Rng & ".xlsx" '之前忘了保存了wb.Closewb1.Sheets(1).Activateabc.Offset(b + 1, 0).SelectNextApplication.DisplayAlerts = TrueEnd SubSub 输入输出()Dim abc As Stringabc = InputBox("你想问什么", "这是一个标题")Call MsgBox("房主你最帅^ ^", 0, "这是标题")'加了括号一定要返回值，或者加call'Dim wb As Workbook' Set wb = Workbooks.Add' wb.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & "woshi.xls" '搞定名称啦！Sub 自动分组打印6_Click()For i = 1 To 35Dim Rng As StringDim abc As RangeWith ActiveCellRng = .ValueSet abc = .Offset(1, 0)End WithDim a As RangeDim b As Integerb = 0For Each a In Range("A:A")If a.Value = Rng Thenb = b + 1End IfNext' MsgBox bActiveCell.Offset(b, 0).EntireRow.SelectSelection.Insert Shift:=xlDownSelection.Insert Shift:=xlDownabc.SelectWorksheets("团队出勤").PageSetup.PrintArea = abc.CurrentRegion.AddressWorksheets("团队出勤").PrintOutRange("a1").EntireRow.Copy abc.Offset(b, 0)abc.Offset(b + 1, 0).SelectNextEnd SubPublic Sub多个工作表复制汇总()Dim p$, f$, z$, i As IntegerDim wb As WorksheetDim wb1 As WorkbookDim rng As RangeApplication.ScreenUpdating = FalseSet wb = ThisWorkbook.Worksheets(1)' p = "D:\学习\大二下\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\" & ""f = Dir(ThisWorkbook.Path & "\*.xls") '取得第一个excel文件名Do While f <> "" ' 循环语句Set rng = wb.Range("A1048576").End(xlUp).Offset(1, 0) ' ‘Set wb1 = "D:\学习\大二下\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\" & fz = ThisWorkbook.Path & "\" & fSet wb1 = GetObject(z)wb1.Sheets(2).ActivateColumns("Q:Q").SelectSelection.AutoFilter '筛选已验证过没问题ActiveSheet.Range("Q:Q").AutoFilter Field:=1, Criteria1:="发明申请"Rows("2:2").SelectSelection.Insert Shift:=xlDownRange("a3").CurrentRegion.Copy rngwb1.Close False'wb.Activate' Set rng = wb.Worksheets(1).Range("A1048576").End(xlUp).Offset(1, 0) ' rng.PasteSpecial Paste:=xlPasteValues'Range("a1").Value = p & f'MsgBox p & f 显示路径加文件名f = Dir '第二个文件名LoopApplication.ScreenUpdating = TrueEnd SubSub 股票分类建立工作表()Application.DisplayAlerts = FalseDim Rng As StringDim abc As RangeDim b As IntegerDim a As RangeDim sht As WorksheetRng = Worksheets("沪深300成分股10年").Range("b2").ValueSet abc = Worksheets("沪深300成分股10年").Range("b2")Do While Rng <> ""b = 0For Each a In Range("b:b")If a.Value = Rng Thenb = b + 1End IfNextWorksheets("沪深300成分股10年").Activateabc.Offset(b, 0).EntireRow.SelectSelection.Insert Shift:=xlDownSet sht = Worksheets.Add = RngWorksheets("沪深300成分股10年").Activateabc.CurrentRegion.Copy sht.Range("a1")Set abc = abc.Offset(b + 1, 0)Rng = abc.ValueLoopEnd SubSub 遍历工作表求偏度峰度For Each sheet In Sheetssheet.SelectActiveSheet.Range("F1").SelectActiveCell.FormulaR1C1 = "=LN(RC[-2]/RC[-1])"Set rng = ActiveSheet.Range("A1048576").End(xlUp)a = rng.RowActiveSheet.Range("F2").SelectActiveCell.FormulaR1C1 = "=LN(RC[-2]/R[-1]C[-2])"ActiveSheet.Range("F2").SelectSelection.AutoFill Destination:=Range("F2:F" & a)ActiveSheet.Range("F2:F" & a).SelectActiveSheet.Range("G1").SelectActiveCell.FormulaR1C1 = "=KURT(C[-1])"ActiveSheet.Range("H1").SelectActiveCell.FormulaR1C1 = "=SKEW(C[-2])"NextEnd SubSub 求单只股票每一年风度偏度()'Sub 每年()'' 每年宏Dim rng, rng1, rng2 As RangeDim a, c, e, d As StringDim sheet As WorksheetDim b, i, f As LongApplication.ScreenUpdating = falseFor Each sheet In Sheetssheet.Select'选中活动工作表‘k= ActiveSheet.Range("A1").CurrentRegion.Rows.Count ‘ 取得最后一行的行号k 为longSet rng = ActiveSheet.Range("A1048576").End(xlUp) '获得最后一个非空单元格a = rng.Row '非空单元格的行号ActiveSheet.Range("j1").SelectActiveCell.FormulaR1C1 = "=TEXT(RC[-7],""yyyy"")" 'j1输入文本Range("J1").SelectSelection.AutoFill Destination:=Range("J1:J" & a) '自动填充所有行Set rng1 = ActiveSheet.Range("j1")i = 1Do While rng1 <> ""c = rng1.Rowb = 0For Each rng2 In Range("j:j")If rng2.Value = rng1.value Thenb = b + 1End IfNext '获得每一年的个数d = rng1.Offset(b - 1, 0).Rowe = rng1.ValueActiveSheet.Cells(i, 11).Value = eActiveSheet.Cells(i, 12).Value = Application.WorksheetFunction.Kurt(sheet.Range("F" & c & ":F" & d))ActiveSheet.Cells(i, 13).Value = Application.WorksheetFunction.Skew(sheet.Range("F" & c & ":F" & d)) '计算i = i + 1Set rng1 = rng1.Offset(b, 0)LoopnextApplication.ScreenUpdating = True-探戈写的代码：Sub test2()Dim Filename As String, wb As Workbook, Erow As Long, fn As String, bj As Variant, i As Long, k As Long, j As Long, l As Long Filename = Dir(ThisWorkbook.Path & "\*.xls")Do While Filename <> ""If Filename <> Thenfn = ThisWorkbook.Path & "\" & FilenameWorkbooks.Open (fn)With ActiveWorkbook.Worksheets(1)Cells(65536, "A").End(xlUp).EntireRow.DeleteErow = Cells(65536, "C").End(xlUp).RowCells(3, "F").FormulaR1C1 = "=Year(RC[-3])"Cells(3, "F").AutoFill Destination:=Range(Cells(3, "F"), Cells(Erow, "F"))Cells(1, "G") = "年份"Cells(1, "H") = "峰度"Cells(1, "I") = "偏度"i = 3l = 3bj = Cells(i, "F").Valuek = 2007j = 3Do While k <> 2018Do While bj = kbj = Cells(i, "F").Valuei = i + 1LoopCells(j, "H").Formula = "=KURT(R" & l & "C5:R" & i & "C5)"Cells(j, "I").Formula = "=SKEW(R" & l & "C5:R" & i & "C5)"Cells(j, "G").Value = kl = i + 1k = k + 1j = j + 1LoopEnd WithActiveWorkbook.Close savechanges:=TrueEnd IfFilename = DirLoopEnd Sub使用cells.formula 调用工作表函数Cells(1, 1).Formula = "=sum（d" & l & ":d3) "Sub 计算个股（单个工作簿工作表）的收益率和偏度峰度a()'Sub 计算偏度峰度a()'' 每年宏Dim rng, rng1, rng2, rng3 As RangeDim a, c, e, d As StringDim sheet As WorksheetDim b, i, f, k As LongDim filename, fn As Stringfilename = Dir(ThisWorkbook.Path & "\*.xls")Application.ScreenUpdating = FalseDo While filename <> ""If filename <> Thenfn = ThisWorkbook.Path & "\" & filenameWorkbooks.Open (fn)ActiveWorkbook.Worksheets(1).SelectActiveSheet.Range("g2").Value = "长期收益率"ActiveSheet.Range("h2").Value = "长期峰度"ActiveSheet.Range("i2").Value = "长期偏度"ActiveSheet.Range("l2").Value = "每年收益率"ActiveSheet.Range("m2").Value = "每年峰度"ActiveSheet.Range("n2").Value = "每年偏度"ActiveSheet.Range("e3").SelectActiveCell.FormulaR1C1 = "=LN(RC[-1]/R[-1]C[-1])"k = ActiveSheet.Range("A1").CurrentRegion.Rows.CountActiveSheet.Range("e3").SelectSelection.AutoFill Destination:=Range("e3:e" & k)ActiveSheet.Cells(3, 8).Formula = "=KURT（e3:e" & k & ") " '算十年ActiveSheet.Cells(3, 9).Formula = "=skew(e3：e" & k & ") "ActiveSheet.Cells(3, 7).Formula = "=d" & k & "/d2 -1 "'选中活动工作表'非空单元格的行号ActiveSheet.Range("j3").SelectActiveCell.FormulaR1C1 = "=TEXT(RC[-7],""yyyy"")" 'j1输入文本Range("J3").SelectSelection.AutoFill Destination:=Range("J3:J" & k) '自动填充所有行Set rng1 = ActiveSheet.Range("j3")i = 3Do While rng1 <> ""c = rng1.Rowb = 0For Each rng2 In Range("j:j")If rng2.Value = rng1.Value Thenb = b + 1End IfNext '获得每一年的个数d = rng1.Offset(b - 1, 0).Rowe = rng1.ValueActiveSheet.Cells(i, 11).Value = eActiveSheet.Cells(i, 13).Formula = "=KURT（e" & c & ":e" & d & ") "ActiveSheet.Cells(i, 14).Formula = "=skew（e" & c & ":e" & d & ") "ActiveSheet.Cells(i, 12).Formula = "=d" & d & "/d" & c & "-1 "i = i + 1Set rng1 = rng1.Offset(b, 0)LoopActiveWorkbook.Close savechanges:=TrueEnd Iffilename = DirLoopApplication.ScreenUpdating = TrueEnd Sub------------批量总表Dim a, c, e, d As StringDim sheet As WorksheetDim b, i, f, k As LongDim filename, fn As Stringfilename = Dir(ThisWorkbook.Path & "\*.xls")Application.ScreenUpdating = FalseSet rng1 = ThisWorkbook.Sheets(1).Range("a1048576").End(xlUp).Offset(1, 0)i = 1Do While filename <> ""If filename <> Thenfn = ThisWorkbook.Path & "\" & filenameWorkbooks.Open (fn)ActiveWorkbook.Worksheets(1).SelectWith ActiveWorkbook.Worksheets(1).Range("b2").CopyThisWorkbook.Sheets(1).Cells(i, 1).PasteSpecial xlPasteValues.Range("g3:i3").CopyThisWorkbook.Sheets(1).Cells(i, 2).PasteSpecial xlPasteValuesEnd WithActiveWorkbook.Close savechanges:=TrueEnd Ifi= i+1filename = DirLoopApplication.ScreenUpdating = TrueEnd SubPublic Sub 汇总工作簿的不同工作表()Dim f$, z$, i As Long '定义变量Dim wb As WorksheetDim wb1 As WorkbookDim rng As RangeApplication.ScreenUpdating = False ’关闭屏幕更新，加快运行速度Set wb = ThisWorkbook.Worksheets(1) '定义代码所在工作簿的变量f = Dir(ThisWorkbook.Path & "\*.xls") '取得所在文件夹的第一个excel 文件名Do While f <> "" ' 循环语句If f <> Then ’判断该文件是否是代码所在工作簿Set rng = wb.Range("A1048576").End(xlUp).Offset(1, 0) '取得所要汇总的工作簿的A列第一个非空单元格z = ThisWorkbook.Path & "\" & fSet wb1 = Workbooks.Open(z) ’打开其他的工作簿wb1.Sheets(1).Range("B6").CurrentRegion.Copy rng '开始复制其他工作簿的内容到指定位置。
VBA代码汇总范文
VBA代码汇总范文VBA（Visual Basic for Applications）是一种用于自动化任务和宏编程的编程语言。
它是Microsoft Office套件的一部分，用于自动执行重复的任务和增强办公软件的功能。
以下是一些常用的VBA代码汇总，供参考和学习：1.向单元格中填入数值或文本：```vbaRange("A1").Value = 10Range("A2").Value = "Hello, world!"```2.循环遍历单元格：```vbaFor Each cell In Range("A1:A10")'逐个处理单元格MsgBox cell.ValueNext cell```3.创建新的工作表：```vbaSet ws = Sheets.Add = "New Sheet"```4.删除工作表：```vbaSheets("Sheet1").Delete```5.自动筛选数据：```vbaActiveSheet.Range("A1:D10").AutoFilter Field:=1, Criteria1:="Apple"```6.打开文件对话框并选择文件：```vbaWith Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False.ShowIf .SelectedItems.Count > 0 ThenMsgBox .SelectedItems(1)MsgBox "No file selected."End IfEnd With```7.在单元格中执行计算：```vbaRange("C1").Formula = "=SUM(A1:B1)"```8.隐藏行或列：```vbaColumns("A").Hidden = TrueRows("1:5").Hidden = True```9.在单元格中显示当前日期和时间：```vbaRange("A1").Value = Now```10.复制和粘贴单元格：Range("A1").Copy Destination:=Range("B1")```11.保存文件：```vbaActiveWorkbook.SaveAs "C:\MyFolder\MyFile.xlsx"```12.打开网页并获取内容：```vbaSet objHTTP = CreateObject("MSXML2.ServerXMLHTTP") objHTTP.Open "GET", URL, FalseobjHTTP.SendMsgBox objHTTP.ResponseText```13.设置单元格格式：```vbaRange("A1").NumberFormat = "0.00"```14.创建图表：Set chartObj = ActiveSheet.Shapes.AddChart2(251, xlColumnClustered)chartObj.SelectActiveChart.SetSourceData Source:=Range("A1:B5")```15.在窗口中显示消息框：```vbaMsgBox "Hello, world!"```以上只是一些常见的VBA代码示例，可以根据具体需求进行修改和扩展。
vba常用代码大全
前言我们平时在工作表单元格的公式中常常使用函数，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。
vba 工作表汇总代码
vba 工作表汇总代码摘要：1.VBA编程简介2.工作表汇总代码的编写方法3.代码实例及解析4.代码优化与实用技巧5.总结与建议正文：VBA（Visual Basic for Applications）是一种为Microsoft Office应用程序设计的编程语言，广泛应用于Excel、Word等办公软件中。
本文将介绍如何利用VBA编写工作表汇总代码，对表格数据进行自动化处理。
一、VBA编程简介VBA编程是一种基于事件的编程方式，它允许你在Office应用程序中自定义功能。
通过学习VBA，你可以轻松地实现自动化任务，如数据筛选、排序、计算等。
VBA编程的主要步骤包括：1.打开Excel，按下Alt + F11键打开VBA编辑器。
2.点击“插入”菜单，选择“模块”新建一个模块。
3.在模块中编写代码，利用VBA语言结构（如循环、条件语句等）实现所需功能。
二、工作表汇总代码的编写方法工作表汇总代码主要包括以下几个部分：1.定义变量：用于存储数据表、单元格引用等。
2.读取数据：使用Worksheet.Range或Range对象读取表格数据。
3.数据处理：利用VBA语句对数据进行筛选、排序、计算等操作。
4.写入数据：将处理后的数据写回表格。
5.错误处理：为避免程序运行过程中出现错误，可使用On Error语句进行错误捕捉。
三、代码实例及解析以下是一个简单的VBA代码实例，用于对工作表中的数据进行求和：```vbaSub 求和()Dim ws As WorksheetDim sum As DoubleDim cellValue As Variant" 设置工作表对象Set ws = ThisWorkbook.Worksheets("Sheet1")" 定义求和范围Set range = ws.Range("A1:C10")" 循环读取单元格值For Each cellValue In range.Cellssum = sum + cellValueNext cellValue" 结果显示在D1单元格ws.Range("D1").Value = sumEnd Sub```四、代码优化与实用技巧1.使用With语句简化代码，提高可读性。
VBA代码全集模板
目录一、引用 (3)二、Worksheet_Change事件： (3)三、相乘 (5)四、相减 (6)五、高级筛选 (6)六、双击事件 (8)七．单位汇总（sumif），单条件汇总 (10)八、多条件汇总（连接、sumif） (13)九、多条件汇总、ado (15)十、对账 (16)十一、sql筛选 (20)十二、sql连接、交叉汇总 (21)十三、select语句总结 (23)十四、报表（有层次） (24)一、引用相对引用B4绝对引用$B$4混合引用$B4、B$4F4进行引用切换，$在字母前面则锁定列，在数字前面则锁定行。
二、Worksheet_Change 事件：1.在单元格中C4=VLOOKUP(B4,简码表!$B$4:$C$1000,2,FALSE)2. Worksheet_Change事件代码：Private Sub Worksheet_Change(ByVal Target As Range)On error resume nextIf Target.Row > 3 And Target.Column = 2 Theni = Target.RowCells(i, 3) = Application.WorksheetFunction.VLookup(Cells(i, 2), Sheets("简码表").Range("b4:c100"), 2, False)End IfEnd Sub备查代码：Private Sub Worksheet_Change(ByVal Target As Range)On Error Resume NextIf Target.Row > 3 And Target.Column = 5 Theni = Target.RowCells(i, 6) = Application.WorksheetFunction.VLookup(Cells(i, 5), Sheets("类款项").Range("b2:e2000"), 2, False)Cells(i, 7) = Application.WorksheetFunction.VLookup(Cells(i, 5), Sheets("类款项").Range("b2:e2000"), 3,False)Cells(i, 8) = Application.WorksheetFunction.VLookup(Cells(i, 5), Sheets("类款项").Range("b2:e2000"), 4, False)End IfEnd Sub三、相乘Sub 计算金额()Application.ScreenUpdating = FalseDim i As LongDim irow As Longirow = Range("a3").End(xldown).RowFor i = 4 To irowCells(i, 3) = Cells(i, 1) * Cells(i, 2)Next iApplication.ScreenUpdating = TrueEnd Sub四、相减Sub 相减()Application.ScreenUpdating = FalseRange("c3:c10000").ClearContentsDim i As LongDim irow As Longirow = Range("a5000").End(xlUp).RowFor i = 3 To irowCells(i, 3) = VBA.Round((Cells(i, 1) - Cells(i, 2)), 2)Next iApplication.ScreenUpdating = TrueEnd Sub五、高级筛选（工具-宏-录制新宏，宏名改成高级筛选）Sub 高级筛选()Sheets("业务").Range("A3:I10000").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=ActiveCell.Range("A1:B1"), Unique:=TrueEnd Sub六、双击事件1.插入-名称-定义（修改名称和引用位置）2．查看代码-插入-用户窗体工具箱-多页、列表框-右键属性点击page1修改caption为资产类-点击空白列表框修改rowsource 为box1依次类推3. 业务表-查看代码 Worksheet beforedoubleclickPrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Row > 3 And Target.Column = 6 ThenUserForm1.ShowSheets("初始化").Range("m3") = ActiveCellElseIf Target.Row > 3 And Target.Column = 7 ThenUserForm2.ShowEnd IfEnd Sub备查代码：Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Row > 3 And Target.Column = 6 ThenUserForm1.ShowSheets("初始化").Range("c2") = ActiveCellElseIf Target.Row > 3 And Target.Column = 7 ThenUserForm2.ShowSheets("初始化").Range("f2") = ActiveCellElseIf Target.Row > 3 And Target.Column = 8 ThenUserForm3.ShowEnd IfEnd Sub4．右键点击Userform1查看代码 Listbox1 dbclickPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox1.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox2.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox3.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox4.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox5.ListIndex, 0)Unload MeEnd Sub见上图5.插入用户窗体右键点击userform2 worksheet dblclickPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row, 7) = ListBox1.List(ListBox1.ListIndex, 0)Unload MeEnd SubUserform initializePrivate Sub UserForm_Initialize()Application.ScreenUpdating = FalseWith Sheets("初始化")Sheets("科目表").Range("h2:i10000").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=.Range("m2:m3"), CopyToRange:=.Range("n2"), Unique:=TrueEnd WithApplication.ScreenUpdating = TrueEnd Sub七．单位汇总（sumif），单条件汇总=SUMIF(业务!$D$4:$D$1000,单位汇总!$A15,业务!I$4:I$10000)Sub 单位汇总1()Application.ScreenUpdating = Falserange("a1:i10000").ClearCells(3, 2) = "指标数"Cells(3, 3) = "拨款数"Cells(3, 4) = "余额"Cells(1, 7) = "单位"Cells(3, 7) = "单位"Cells(3, 8) = "指标数"Cells(3, 9) = "拨款数"Sheets("业务").Range("D3:D10000").AdvancedFilter Action:=xlFilterCopy, _CopyToRange:=Range("A3"), Unique:=TrueSheets("业务").Range("A3:J10000").AdvancedFilter Action:=xlFilterCopy, _CriteriaRange:=Range("G1:G2"), CopyToRange:=Range("G3:I3"), Unique:=FalseDim i As LongDim irow As Longirow = Range("a3").End(xlDown).RowFor i = 4 To irowCells(i, 2) = Application.WorksheetFunction.SumIf(Range("g4:g10000"), Cells(i, 1), Range("h4:h10000"))Cells(i, 3) = Application.WorksheetFunction.SumIf(Range("g4:g10000"), Cells(i, 1), Range("i4:i10000"))Cells(i, 4) = VBA.Round(Cells(i, 2) - Cells(i, 3), 2)Next iRange("g1:i10000").ClearApplication.ScreenUpdating = TrueEnd Sub八、多条件汇总（连接、sumif）连接=k4&l4&m4&n4Vba：Sub 多条件汇总()Application.ScreenUpdating = FalseRange("a1:p10000").ClearSheets("业务").Range("D3:G10000").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=Range("B3:E3"), Unique:=TrueSheets("业务").Range("D3:I10000").AdvancedFilter Action:=xlFilterCopy, _CopyToRange:=Range("K3:P3"), Unique:=FalseDim j As LongDim jrow As Longjrow = Range("k3").End(xlDown).RowFor j = 4 To jrowCells(j, 10) = Cells(j, 11) & Cells(j, 12) & Cells(j, 13) & Cells(j, 14)Next jDim i As LongDim irow As Longirow = Range("b3").End(xlDown).RowFor i = 4 To irowCells(3, 6) = "指标数"Cells(3, 7) = "拨款数"Cells(3, 8) = "余额"Cells(i, 1) = Cells(i, 2) & Cells(i, 3) & Cells(i, 4) & Cells(i, 5)Cells(i, 6) = Application.WorksheetFunction.SumIf(Range("j4:j10000"), Cells(i, 1), Range("o4:o10000"))Cells(i, 7) = Application.WorksheetFunction.SumIf(Range("j4:j10000"), Cells(i, 1), Range("p4:p10000"))Cells(i, 8) = VBA.Round(Cells(i, 6) - Cells(i, 7), 2)Next iRange("i3:p10000").ClearRange("a1:a10000").DeleteApplication.ScreenUpdating = TrueEnd Sub九、多条件汇总、adoSub 多条件汇总()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类,款,项, sum(指标数) as 预算股指标,sum(拨款数) as 预算股拨款 from[业务$a3:J10000] where 归口='" & Range("h2").Value & "'and 月<=" & Range("i2").Value & " GROUP BY 单位,类,款,项"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("多条件汇总").Cells(3, i) = rst.Fields(i - 1).Name Next iSheets("多条件汇总").Range("a4").CopyFromRecordset rst rst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd Sub十、对账Sub 预算股()Application.ScreenUpdating = FalseDim i As IntegerDim strsql1 As StringDim cnn1 As New ADODB.ConnectionDim rst1 As New ADODB.Recordsetcnn1.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql1 = " SELECT 单位,类,款,项, sum(指标数) as 预算股指标 from[预算股$a3:m50000] where 归口='" & Range("h2").Value & "'and 月<=" & Range("i2").Value & " GROUP BY 单位,类,款,项" rst1.Open strsql1, cnn1For i = 1 To rst1.Fields.CountSheets("对帐").Cells(3, i + 10) = rst1.Fields(i - 1).NameNext iSheets("对帐").Range("k4").CopyFromRecordset rst1rst1.Closecnn1.CloseSet rst1 = NothingSet cnn1 = NothingDim strsql2 As StringDim cnn2 As New ADODB.ConnectionDim rst2 As New ADODB.Recordsetcnn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql2 = " SELECT 单位,类,款,项, sum(指标数) as 专业股指标 from[专业股$a3:j50000] where 归口='" & Range("h2").Value & "'and 月<=" & Range("i2").Value & " GROUP BY 单位,类,款,项" rst2.Open strsql2, cnn2For i = 1 To rst2.Fields.CountSheets("对帐").Cells(3, i + 19) = rst2.Fields(i - 1).NameNext iSheets("对帐").Range("t4").CopyFromRecordset rst2rst2.Closecnn2.CloseSet rst2 = NothingSet cnn2 = Nothings = Application.WorksheetFunction.CountA(Range("k4:k10000")) + 4Range("T4:W10000").SelectSelection.CopyRange("K" & s).SelectActiveSheet.PasteRange("X4:X10000").SelectSelection.CopyRange("P" & s).SelectActiveSheet.PasteRange("X3").SelectSelection.CopyRange("P3").SelectActiveSheet.PasteDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类,款,项, sum(预算股指标) as 预算股指标 ,sum(专业股指标) as 专业股指标 from[对帐$k3:p50000] GROUP BY 单位,类,款,项"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("对帐").Cells(3, i) = rst.Fields(i - 1).NameNext iSheets("对帐").Range("a4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd Sub十一、sql筛选Sub 筛选()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT distinct 单位,类,款,项 from[专业$a3:h10000]"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("筛选").Cells(3, i) = rst.Fields(i - 1).NameNext iSheets("筛选").Range("a4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = True End Sub十二、sql连接、交叉汇总Sub 连接()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 股,月,归口,单位,类,款,项,指标数 from [专业$a3:h10000] union ALL SELECT 股,月,归口,单位,类,款,项,指标数 from [预算$a3:l10000] order by 股 desc"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("连接").Cells(1, i + 19) = rst.Fields(i - 1).NameNext iSheets("连接").Range("t2").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd SubSub 汇总()Application.ScreenUpdating = FalseCall 连接Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " transform sum(指标数) SELECT 单位,类,款,项 from [连接$t1:aa10000] where 归口= '" & Range("h2").Value & "' and 月=" & Range("i2").Value & " group by 单位,类,款,项 pivot 股" rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("连接").Cells(3, i) = rst.Fields(i - 1).NameNext iSheets("连接").Range("a4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingRange("t1:aa10000").ClearContentsApplication.ScreenUpdating = TrueEnd Sub十三、select语句总结1、筛选（false ---筛选全部）Select 列表名称1,列表名称2,…….列表名称n from [表$区域]或者Select * from [表$区域]2、筛选唯一的数据Select distinct 列表名称1,列表名称2,…….列表名称n from [表$区域]3、分类汇总Select 列表名称1,列表名称2,…….列表名称n，sum(a) as a from [表$区域]Group by列表名称1,列表名称2,…….列表名称n4、条件分类汇总Select 列表名称1,列表名称2,…….列表名称n，sum(a) as a from [表$区域]Where 归口=’”& range(“”).value &”’ and 月=”& range(“”).value &” Group by列表名称1,列表名称2,…….列表名称n5、交叉汇总Transform sum() select 列名称1,……列名称n from[表$区域] group by 列名称1，…..列名称n pivot 交叉事项6、连接Select 列名称1，…列名称n from[表$区域] union all Select 列名称1，…列名称n from[表$区域] order by 列名称 desc十四、报表（有层次）连接Transform sum（指标数），pivot 股按单位、类、款进行汇总按单位、类进行汇总按单位进行汇总连接以上四个表的内容，并按单位、类、款、项进行排序，其中单位按降序排序1、整体写代码Sub 报表()Application.ScreenUpdating = FalseDim i As IntegerDim strsql1 As StringDim cnn1 As New ADODB.ConnectionDim rst1 As New ADODB.Recordsetcnn1.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql1 = " SELECT 股,月,归口,单位,类,款,项,sum(指标数) as 指标数 from[专业$a3:h10000] group by 股,月,归口,单位,类,款,项 union all SELECT 股,月,归口,单位,类,款,项,sum(指标数) as 指标数 from[预算$a3:l10000] group by 股,月,归口,单位,类,款,项 order by 股 desc"rst1.Open strsql1, cnn1For i = 1 To rst1.Fields.CountSheets("报表").Cells(3, i + 9) = rst1.Fields(i - 1).NameNext iSheets("报表").Range("j4").CopyFromRecordset rst1rst1.Closecnn1.CloseSet rst1 = NothingSet cnn1 = NothingDim strsql2 As StringDim cnn2 As New ADODB.ConnectionDim rst2 As New ADODB.Recordsetcnn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql2 = "transform sum(指标数) SELECT 单位,类,款,项 from[报表$j3:q10000] where 归口='" & Range("g2") _.Value & "' and 月<=" & Range("h2").Value & " group by 单位,类,款,项 order by 单位 desc pivot 股 "rst2.Open strsql2, cnn2For i = 1 To rst2.Fields.CountSheets("报表").Cells(3, i + 19) = rst2.Fields(i - 1).NameNext iSheets("报表").Range("t4").CopyFromRecordset rst2rst2.Closecnn2.CloseSet rst2 = NothingSet cnn2 = NothingDim strsql3 As StringDim cnn3 As New ADODB.ConnectionDim rst3 As New ADODB.Recordsetcnn3.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql3 = "SELECT 单位,类,款,sum(专业股) as 专业股,sum(预算股) as 预算股 from[报表$t3:y10000] group by 单位,类,款 order by 单位 desc"rst3.Open strsql3, cnn3For i = 1 To rst3.Fields.CountSheets("报表").Cells(3, i + 26) = rst3.Fields(i - 1).NameNext iSheets("报表").Range("aa4").CopyFromRecordset rst3rst3.Closecnn3.CloseSet rst3 = NothingSet cnn3 = NothingDim strsql4 As StringDim cnn4 As New ADODB.ConnectionDim rst4 As New ADODB.Recordsetcnn4.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql4 = "SELECT 单位,类,sum(专业股) as 专业股,sum(预算股) as 预算股 from[报表$t3:y10000] group by 单位,类 order by 单位 desc"rst4.Open strsql4, cnn4For i = 1 To rst4.Fields.CountSheets("报表").Cells(3, i + 32) = rst4.Fields(i - 1).NameNext iSheets("报表").Range("ag4").CopyFromRecordset rst4rst4.Closecnn4.CloseSet rst4 = NothingSet cnn4 = NothingDim strsql5 As StringDim cnn5 As New ADODB.ConnectionDim rst5 As New ADODB.Recordsetcnn5.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql5 = "SELECT 单位,sum(专业股) as 专业股,sum(预算股) as 预算股 from[报表$t3:y10000] group by 单位 order by 单位 desc"rst5.Open strsql5, cnn5For i = 1 To rst5.Fields.CountSheets("报表").Cells(3, i + 37) = rst5.Fields(i - 1).NameNext iSheets("报表").Range("al4").CopyFromRecordset rst5rst5.Closecnn5.CloseSet rst5 = NothingSet cnn5 = NothingColumns("AD:AD").SelectSelection.Insert Shift:=xlToRightRange("ad3") = "项"Columns("Aj:Ak").SelectSelection.Insert Shift:=xlToRightRange("aj3") = "款"Range("ak3") = "项"Columns("Ap:Ar").SelectSelection.Insert Shift:=xlToRightRange("ap3") = "类"Range("aq3") = "款"Range("ar3") = "项"Dim strsql6 As StringDim cnn6 As New ADODB.ConnectionDim rst6 As New ADODB.Recordsetcnn6.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql6 = " SELECT 单位,类,款,项,专业股,预算股 from [报表$t3:y10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$aa3:af10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$ah3:am10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$ao3:at10000] order by 单位 desc,类,款,项 "rst6.Open strsql6, cnn6For i = 1 To rst6.Fields.CountSheets("报表").Cells(3, i) = rst6.Fields(i - 1).NameNext iSheets("报表").Range("a4").CopyFromRecordset rst6rst6.Closecnn6.CloseSet rst6 = NothingSet cnn6 = NothingRange("j1:au10000").ClearContentsDim p As LongDim prow As Longprow = Range("a3").End(xlDown).RowFor p = 4 To prowRange("g3") = "金额"Cells(p, 7) = VBA.Round(Cells(p, 6) - Cells(p, 5), 2)Next pApplication.ScreenUpdating = TrueEnd Sub2、分开写代码：Sub 连接()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 月,归口,股,单位,类,款,项,sum(指标数) as 指标数 from[专业$a3:h10000] group by 月,归口,股,单位,类,款,项 union all SELECT 月, 归口,股,单位,类,款,项,sum(指标数) as 指标数 from[预算$a3:l10000] group by 月, 归口,股,单位,类,款,项 order by 股 desc"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 9) = rst.Fields(i - 1).NameNext iSheets("报表").Range("j4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd SubSub 项()Application.ScreenUpdating = FalseCall 连接Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';DataSource=" & ThisWorkbook.FullNamestrsql = "transform sum(指标数) SELECT 单位,类,款,项 from [报表$j3:q10000] where 归口= '" & Range("g2").Value & "' and 月<=" & Range("h2").Value & " group by 单位,类,款,项 pivot 股"rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 19) = rst.Fields(i - 1).NameNext iSheets("报表").Range("t4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd SubSub 款()Application.ScreenUpdating = FalseCall 项Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类,款, sum(专业股) as 专业股, sum(预算股) as 预算股 from [报表$t3:y10000] group by 单位,类,款 "rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 26) = rst.Fields(i - 1).NameNext iSheets("报表").Range("aa4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingColumns("AD:AD").SelectSelection.Insert Shift:=xlToRightCells(3, 30) = "项"Application.ScreenUpdating = TrueEnd SubSub 类()Application.ScreenUpdating = FalseCall 款Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类, sum(专业股) as 专业股, sum(预算股) as 预算股 from [报表$aa3:af10000] group by 单位,类 "rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 33) = rst.Fields(i - 1).NameNext iSheets("报表").Range("ah4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingColumns("AJ:AJ").SelectSelection.Insert Shift:=xlToRightColumns("AK:AK").SelectSelection.Insert Shift:=xlToRightRange("AJ3").SelectActiveCell.FormulaR1C1 = "款"Range("AK3").SelectActiveCell.FormulaR1C1 = "项"Application.ScreenUpdating = TrueEnd SubSub 单位()Application.ScreenUpdating = FalseCall 类Dim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位, sum(专业股) as 专业股, sum(预算股) as 预算股 from [报表$ah3:am10000] group by 单位 "rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i + 40) = rst.Fields(i - 1).NameNext iSheets("报表").Range("ao4").CopyFromRecordset rstrst.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = True Columns("AP:AP").SelectSelection.Insert Shift:=xlToRight Columns("AQ:AQ").SelectSelection.Insert Shift:=xlToRight Columns("AR:AR").SelectSelection.Insert Shift:=xlToRight Range("AP3").SelectActiveCell.FormulaR1C1 = "类"Range("AQ3").SelectActiveCell.FormulaR1C1 = "款"Range("AR3").SelectActiveCell.FormulaR1C1 = "项" End SubSub 报表()If Range("i2") = "类" ThenCall 类ElseIf Range("i2") = "款" ThenCall 款ElseCall 项End IfEnd SubSub 总报表()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Hdr=Yes';Data Source=" & ThisWorkbook.FullNamestrsql = " SELECT 单位,类,款,项,专业股,预算股 from [报表$t3:y10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$aa3:af10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$ah3:am10000] union all SELECT 单位,类,款,项,专业股,预算股 from [报表$ao3:at10000] order by 单位 desc,类,款,项 "rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets("报表").Cells(3, i) = rst.Fields(i - 1).NameNext iSheets("报表").Range("a4").CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingRange("j1:br10000").ClearApplication.ScreenUpdating = TrueEnd Sub插入图片Sub 按钮48_单击() 宏按钮名，编码时自动生成On Error Resume NextDim MR As RangeFor Each MR In SelectionIf Not IsEmpty(MR) ThenMR.SelectML = MR.LeftMT = MR.TopMW = MR.WidthMH = MR.HeightActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).SelecterPicture _End IfNextEnd Sub与EXCEL表在同一个文件夹里，。
vba经常使用代码大全
前言咱们平常在工作表单元格的公式中常常利用函数，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。