VBA代码全集模板.docx

1、VBA代码全集模板一、引用相对引用B4绝对引用$B$4混合引用$B4、B$4 F4进行引用切换，$在字母前面则锁定列，在数字前面则锁定行。二、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)

2、= 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),

3、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 =

4、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(xlU

5、p).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.插入-名称-定义

6、（修改名称和引用位置）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) = ActiveCellEl

7、seIf 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 ThenUserFor

8、m2.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 M

9、eEnd 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.Lis

10、tIndex, 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

11、.List(ListBox5.ListIndex, 0)Unload MeEnd Sub见上图5.插入用户窗体 右键点击userform2 worksheet dblclick Private 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()

12、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)Su

13、b 单位汇总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(

14、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

15、, 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

16、: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 j

17、rowCells(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) = Applicatio

18、n.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

19、 = 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 单

20、位,类,款,项, 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).NameNext iSheets(多条件汇总).Range(a4).CopyFromRecordset rstrst.Closecnn.C

21、loseSet 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;Hd

22、r=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(对帐

23、).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 =

24、 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.Cl

25、oseSet rst2 = NothingSet cnn2 = Nothings = Application.WorksheetFunction.CountA(Range(k4:k10000) + 4Range(T4:W10000).Select Selection.Copy Range(K & s).Select ActiveSheet.Paste Range(X4:X10000).Select Selection.Copy Range(P & s).Select ActiveSheet.Paste Range(X3).Select Selection.Copy Range(P3).Sele

26、ct ActiveSheet.Paste Dim 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:p5000

27、0 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 =

28、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:h10000rst.Open strsql, cnnFor i = 1 To

29、 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 c

30、nn 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 股 descrst.Open strsql, cnnFor i = 1 To rst.Fields.CountSheets(