VBA代码全集模板.doc

1、VBA 代码全集云南农业大学1VBA 代码全集目录一、引用3二、 Worksheet_Change事件：3三、相乘5四、相减6五、高级筛选6六、双击事件8七单位汇总（sumif），单条件汇总10八、多条件汇总（连接、 sumif）13九、多条件汇总、ado15十、对账16十一、 sql筛选20十二、 sql连接、交叉汇总21十三、 select语句总结23十四、报表（有层次）24云南农业大学2VBA 代码全集一、引用相对引用 B4绝对引用 $B$4混合引用 $B4、B$4F4 进行引用切换， $在字母前面则锁定列，在数字前面则锁定行。二、 Worksheet_Change 事件：1.在单元格中

2、 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 Then i = Target.RowCells(i, 3) = Application.WorksheetFunction.VLookup(Cells(i, 2), Sheets( 简码表云南农业大学3VBA 代码全集).Range(b4:c100

3、), 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.VLook

4、up(Cells(i,5),Sheets(类款项 ).Range(b2:e2000),3,云南农业大学4VBA 代码全集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 T

5、o irowCells(i, 3) = Cells(i, 1) * Cells(i, 2)Next iApplication.ScreenUpdating = TrueEnd Sub云南农业大学5VBA 代码全集四、相减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) - C

6、ells(i, 2), 2)Next iApplication.ScreenUpdating = TrueEnd Sub五、高级筛选（工具 -宏-录制新宏，宏名改成高级筛选）云南农业大学6VBA 代码全集Sub 高级筛选 ()Sheets(业务 ).Range(A3:I10000).AdvancedFilter Action:=xlFilterCopy, _CopyToRange:=ActiveCell.Range(A1:B1), Unique:=TrueEnd Sub云南农业大学7VBA 代码全集六、双击事件1. 插入 - 名称 - 定义（修改名称和引用位置）2查看代码 - 插入 - 用户窗

7、体工具箱 - 多页、列表框 - 右键属性点击 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) = ActiveCell云南农业大学8VBA 代码全

8、集ElseIf 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 ThenUs

9、erForm2.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)

10、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(List

11、Box3.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)云南农业大学9VBA 代码全集ActiveSheet.Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox4.ListIndex, 0)Unload MeEnd SubPrivate Sub ListBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(Active

12、Cell.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 Su

13、b 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$100

14、0, 单位汇总!$A15, 业务 !I$4:I$10000)云南农业大学10VBA 代码全集云南农业大学11VBA 代码全集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 Act

15、ion:=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.Workshe

16、etFunction.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云南农业大学12VBA 代码全集八、多条件汇总（连接、

17、 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, _云南农业大学13VBA 代码全集CopyToRange:=Ra

18、nge(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

19、(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) - C

20、ells(i, 7), 2)Next iRange(i3:p10000).ClearRange(a1:a10000).DeleteApplication.ScreenUpdating = TrueEnd Sub云南农业大学14VBA 代码全集九、多条件汇总、adoSub 多条件汇总 ()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.OpenProvider=Microsof

21、t.Jet.OLEDB.4.0;ExtendedProperties=Excel8.0;Hdr=Yes;DataSource= & ThisWorkbook.FullNamestrsql= SELECT 单位 , 类 , 款 , 项 , sum(指标数 ) as 预算股指标 ,sum( 拨款数 ) as 预算股拨款from业务 $a3:J10000 where归口 = & Range(h2).Value & and月 = & Range(i2).Value & GROUPBY单位,类,款,项rst.Open strsql, cnnFor i = 1 To rst.Fields.Count云南农

22、业大学15VBA 代码全集Sheets( 多条件汇总 ).Cells(3, i) = rst.Fields(i - 1).NameNext iSheets( 多条件汇总 ).Range(a4).CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd Sub十、对账云南农业大学16VBA 代码全集Sub 预算股 ()Application.ScreenUpdating = FalseDim i As IntegerDim strsql

23、1 As StringDim cnn1 As New ADODB.ConnectionDim rst1 As New ADODB.Recordsetcnn1.OpenProvider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties=Excel8.0;Hdr=Yes;DataSource= & ThisWorkbook.FullNamestrsql1= SELECT 单位 , 类, 款 , 项 , sum(指标数 ) as 预算股指标from预算股 $a3:m50000 where 归口 = & Range(h2).Value & and月 = & Rang

24、e(i2).Value & GROUP BY单位 , 类 , 款 , 项 rst1.Open strsql1, cnn1For i = 1 To rst1.Fields.CountSheets( 对帐 ).Cells(3, i + 10) = rst1.Fields(i - 1).Name云南农业大学17VBA 代码全集Next iSheets( 对帐 ).Range(k4).CopyFromRecordset rst1rst1.Closecnn1.CloseSet rst1 = NothingSet cnn1 = NothingDim strsql2 As StringDim cnn2 As

25、 New ADODB.ConnectionDim rst2 As New ADODB.Recordsetcnn2.OpenProvider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties=Excel8.0;Hdr=Yes;DataSource= & ThisWorkbook.FullNamestrsql2= SELECT 单位 , 类, 款 , 项 , sum(指标数 ) as 专业股指标from专业股 $a3:j50000where 归口 = & Range(h2).Value & and月 = & Range(i2).Value & GROUP BY单

26、位 , 类 , 款 , 项 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:W

27、10000).SelectSelection.CopyRange(K & s).SelectActiveSheet.PasteRange(X4:X10000).Select云南农业大学18VBA 代码全集Selection.CopyRange(P & s).SelectActiveSheet.PasteRange(X3).SelectSelection.CopyRange(P3).SelectActiveSheet.PasteDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.

28、OpenProvider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties=Excel8.0;Hdr=Yes;DataSource= & 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) = rs

29、t.Fields(i - 1).NameNext iSheets( 对帐 ).Range(a4).CopyFromRecordset rstrst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd Sub云南农业大学19VBA 代码全集十一、 sql 筛选Sub 筛选 ()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDi

30、m rst As New ADODB.Recordsetcnn.OpenProvider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties=Excel8.0;Hdr=Yes;DataSource= & ThisWorkbook.FullNamestrsql = SELECT distinct单位 , 类 , 款 , 项 from专业 $a3:h10000rst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets( 筛选 ).Cells(3, i) = rst.Fields(i - 1).NameNext i

31、Sheets( 筛选 ).Range(a4).CopyFromRecordset rst云南农业大学20VBA 代码全集rst.Closecnn.CloseSet rst = NothingSet cnn = NothingApplication.ScreenUpdating = TrueEnd Sub十二、 sql 连接、交叉汇总云南农业大学21VBA 代码全集Sub 连接 ()Application.ScreenUpdating = FalseDim i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst

32、 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:h10000union ALL SELECT 股 ,月 , 归口 , 单位 , 类, 款 , 项 , 指标数 from 预算 $a3:l10000 order by股 descrst.Open str

33、sql, 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 = False云南农业大学22VBA 代码全集Call连接Di

34、m i As IntegerDim strsql As StringDim cnn As New ADODB.ConnectionDim rst As New ADODB.Recordsetcnn.OpenProvider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties=Excel8.0;Hdr=Yes;DataSource= & ThisWorkbook.FullNamestrsql= transformsum(指标数 ) SELECT单位 , 类 , 款 , 项 from 连接 $t1:aa10000where 归口 = & Range(h2).Val

35、ue & 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).ClearContentsApplicat

36、ion.ScreenUpdating = TrueEnd Sub十三、 select语句总结1、筛选（ false -筛选全部）Select列表名称1, 列表名称2,. 列表名称n from 表 $区域 或者 Select * from 表$区域 2、筛选唯一的数据Select distinct列表名称1, 列表名称2,. 列表名称n from 表 $区域 3、分类汇总云南农业大学23VBA 代码全集Select1,2,.nsum(a) as a from $Group by1,2,.n4Select1,2,.nsum(a) as a from $Where=” & range( “” ).v

37、alue &” and=”& range( “” ).value &” Group by1,2,.n5Transform sum() select1,n from$ group by1.npivot6Select1n from$ union all Select1n from$ order bydesc十四、报表（有层次）云南农业大学24VBA 代码全集Transform sum （指标数）， pivot股按单位、类、款进行汇总按单位、类进行汇总按单位进行汇总云南农业大学25VBA 代码全集连接以上四个表的内容，并按单位、类、款、项进行排序，其中单位按降序排序1、整体写代码Sub 报表 ()A

38、pplication.ScreenUpdating = FalseDim i As IntegerDim strsql1 As StringDim cnn1 As New ADODB.ConnectionDim rst1 As New ADODB.Recordsetcnn1.OpenProvider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties=Excel8.0;Hdr=Yes;DataSource= & ThisWorkbook.FullNamestrsql1 = SELECT股 , 月 , 归口 , 单位 , 类 , 款 , 项 ,sum( 指标数

39、) as指标数from专业 $a3:h10000group by 股 , 月 , 归口 , 单位 , 类 , 款 , 项 unionallSELECT 股, 月 , 归口 , 单位 , 类, 款 , 项 ,sum( 指标数 ) as指标数 from预算 $a3:l10000 group by股, 月 , 归口 , 单位 , 类, 款 , 项 order by股 descrst1.Open strsql1, cnn1For i = 1 To rst1.Fields.CountSheets( 报表 ).Cells(3, i + 9) = rst1.Fields(i - 1).NameNext iS

40、heets( 报表 ).Range(j4).CopyFromRecordset rst1rst1.Close云南农业大学26VBA 代码全集cnn1.CloseSet rst1 = NothingSet cnn1 = NothingDim strsql2 As StringDim cnn2 As New ADODB.ConnectionDim rst2 As New ADODB.Recordsetcnn2.OpenProvider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties=Excel8.0;Hdr=Yes;DataSource= & ThisWork

41、book.FullNamestrsql2 = transform sum(指标数 ) SELECT 单位 , 类 , 款, 项 from报表 $j3:q10000 where归口 = &Range(g2) _.Value& and 月 = & Range(h2).Value& group by 单位 , 类, 款 , 项 orderby 单位 descpivot股 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