当前位置：文档之家 › VBA代码全集剖析

VBA代码全集剖析

  • 格式：doc
  • 大小：765.30 KB
  • 文档页数：38

目录一、引用 (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,简码表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 = TrueEnd Sub十二、sqlSub 连接()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[表$区域列名称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表在同一个文件夹里，。

合集下载

Excel-VBA-处理图形图表大全剖析

Excel-VBA-处理图形图表大全剖析

Excel-VBA-处理图形图表大全剖析VBA 一、图表各元素在VBA中的表达方式1、图表区VBA名称:ChartArea2、绘图区VBA名称:PlotArea调整绘图区的大小以及在图表中的位置，指定绘图区的Top、Left、Height和Width属性。

3、数据系列VBA名称:Series指定给定系列语法:ChatObject.SeriesCollection(Index)，其中Index是数字范围，从1开始，最大值是图表中系列的数量或系列名称的数量。

4、图表轴VBA名称:Axis指定给定轴的简单语法:ChatObject.Axes(Type)，其中Type指定轴的Excel VBA常量。

辅助轴语法:ChatObject.Axes(Type，AxisGroup)。

5、网格线VBA名称:HasMajorGridlines和HasMinorGridlines 根据需要可以选择显示或者不显示主要网格线或次要网格线。

若显示网格线，可以设置线条的图案(颜色、线宽、线条样式等等)。

6、数据标签VBA名称:DataLabels和DataLabel(1)图表中所有系列的所有点显示特定类型的数据标签或不显示数据标签: ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowNone(2)特定系列显示数值(Y)作为数据标签:With ActiveChart.SeriesCollection(“Xdata”).HasDataLabels=True.ApplyDataLabels Type:=xlDataLabelsShowValue End With(3)特定的点在它的数据标签中显示文字With ActiveChart.SeriesCollection(“Xdata”).Points(1).HasDataLabels=True.DataLabel.Text=”MyLabel”End With(4)将公式放置在某个系列上的某特定点的数据标签中(在公式中需使用RC样式) With ActiveChart.SeriesCollection(“Xdata”).point(1) .HasDataLabels=True.DataLabel.Text=”Sheet1.R1C1”End With7、图表标题、图例和数据表VBA名称:ChartTitle、HasLegend和HasDataTable 可以用VBA指定图表标题和图例的位置、文字和文字格式。

Excel中VBA代码段汇集，附中文解说

Excel中VBA代码段汇集，附中文解说

Excel中VBA代码段汇集，附中文解说vba语句(1) Option Explicit '强制对模块内所有变量进行声明(2) Option Base 1 '指定数组的第一个下标为1(3) On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息(4) On Error GoT o 100 '当错误发生时跳转到过程中的某个位置(5) On Error GoT o 0 '恢复正常的错误提示(6) Application.DisplayAlerts=False '在程序执行过程中使出现的警告框不显示(7) Application.DisplayAlerts=True '在程序执行过程中(8) Application.ScreenUpdating=False '关闭屏幕刷新(9) Application.ScreenUpdating = True '打开屏幕刷新(10) Workbooks.Add() '创建一个新的工作簿(11) Workbooks(“book1.xls”).Activate '激活名为book1的工作簿(12) ThisWorkbook.Save '保存工作簿(13) ThisWorkbook.close '关闭当前工作簿(14) ActiveWorkbook.Sheets.Count '获取活动工作薄中工作表数(15) '返回活动工作薄的名称(16) ‘返回当前工作簿名称(17) ThisWorkbook.FullName ‘返回当前工作簿路径和名(18) (18) edRange.Rows.Count ‘当前工作表中已使用的行数(19) Rows.Count ‘获取工作表的行数(注：考虑兼容性)(20) Sheets(Sheet1).Name= “Sum” '将Sheet1命名为Sum(21) ThisWorkbook.Sheets.Add Before:=Worksheets(1) '添加一个新工作表在第一工作表前(22) ActiveSheet.Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count) '将当前工作表移至工作表的最后(23) Worksheets(Array(“sheet1”,”sheet2”)).Select '同时选择工作表1和工作表2(24) Sheets(“sheet1”).Delete或Sheets(1).Delete '删除工作表1(25) edRange.FormatConditions.Delete ‘删除当前工作表中所有的条件格式(26) Cells.Hyperlinks.Delete ‘取消当前工作表所有超链接(27) ActiveCell.CurrentRegion.Select选择当前活动单元格所包含的范围，上下左右无空行(28) Cells.Select ‘选定当前工作表的所有单元格(29) Range(“A1”).ClearContents '清除活动工作表上单元格A1中的Selection.ClearContents '清除选定区域内容Range(“A1:D4”).Clear '彻底清除A1至D4单元格区域的内容，包括格式(30) Cells.Clear '清除工作表中所有单元格的内容(31) ActiveCell.Offset(1,0).Select '活动单元格下移一行，同理，可下移一列(32) Range(“A1”).Copy Range(“B1”) '复制单元格A1，粘贴到单元格B1中(33) Range(“A1:D8”).Copy Range(“F1”) '将单元格区域复制到单元格F1开始的区域中(34) Range(“A1:D8”).Cut Range(“F1”) '剪切单元格区域A1至D8，复制到单元格F1开始的区域中(35) Range(“A1”).CurrentRegion.Copy Sheets(“Sheet2”).Range(“A1”) '复制包含A1的单元格区域到工作表2中以A1起始的单元格区域中注：CurrentRegion属性等价于定位命令，由一个矩形单元格块组成，周围是一个或多个空行或列(36) ActiveWindow.RangeSelection.Count '活动窗口中选择的单元格数(37) Selection.Count '当前选中区域的单元格数(38) Range(“A1”).Interior.ColorIndex ‘获取单元格A1背景色(39) cells.count ‘返回当前工作表的单元格数(40) Range(“B3”).Resize(11, 3)(41) Union(Range(“A1:A9”),Range(“D1:D9”)) 区域连接(42) Intersect(Range(“A1:B9”),Range(“A1:D9”))) ‘返回的交叉区域(43) Selection.Columns.Count ‘当前选中的单元格区域中的列数(44) Selection.Rows.Count ‘当前选中的单元格区域中的行数(45) edRange.Row ‘获取单元格区域中使用的第一行的行号(46) Application.WorksheetFunction.IsNumber(“A1”) '使用工作表函数检查A1单元格中的数据是否为数字(47)Range(“A:A”).Find(Application.WorksheetFunction.Max(Range(“A:A”))).Activate'激活单元格区域A列中最大值的单元格(48) MsgBox “Hello!” '消息框中显示消息Hello(49) Ans=MsgBox(“Continue?”,vbYesNo) '在消息框中点击“是”按钮，则Ans值为vbYes；点击“否”按钮，则Ans值为vbNo。

(完整word)VBA代码全集

(完整word)VBA代码全集

目录一、引用 (2)二、Worksheet_Change事件： (2)三、相乘 (4)四、相减 (5)五、高级筛选 (5)六、双击事件 (7)七．单位汇总（sumif），单条件汇总 (9)八、多条件汇总（连接、sumif） (11)九、多条件汇总、ado (13)十、对账 (15)十一、sql筛选 (18)十二、sql连接、交叉汇总 (20)十三、select语句总结 (22)十四、报表(有层次) (23)一、引用相对引用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(”类款项")。

Excel-VBA-处理图形图表大全剖析

Excel-VBA-处理图形图表大全剖析

VBA图表剖析一、图表各元素在VBA中的表达方式1、图表区VBA名称：ChartArea2、绘图区VBA名称：PlotArea调整绘图区的大小以及在图表中的位置，指定绘图区的Top、Left、Height和Width属性。

3、数据系列VBA名称：Series指定给定系列语法：ChatObject.SeriesCollection(Index)，其中Index是数字范围，从1开始，最大值是图表中系列的数量或系列名称的数量。

4、图表轴VBA名称：Axis指定给定轴的简单语法：ChatObject.Axes(Type)，其中Type指定轴的Excel VBA常量。

辅助轴语法：ChatObject.Axes(Type，AxisGroup)。

5、网格线VBA名称：HasMajorGridlines和HasMinorGridlines根据需要可以选择显示或者不显示主要网格线或次要网格线。

若显示网格线，可以设置线条的图案(颜色、线宽、线条样式等等)。

6、数据标签VBA名称：DataLabels和DataLabel(1)图表中所有系列的所有点显示特定类型的数据标签或不显示数据标签：ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowNone(2)特定系列显示数值(Y)作为数据标签：With ActiveChart.SeriesCollection(“Xdata”).HasDataLabels=True.ApplyDataLabels Type:=xlDataLabelsShowValueEnd With(3)特定的点在它的数据标签中显示文字With ActiveChart.SeriesCollection(“Xdata”).Points(1).HasDataLabels=True.DataLabel.Text=”MyLabel”End With(4)将公式放置在某个系列上的某特定点的数据标签中(在公式中需使用RC样式) With ActiveChart.SeriesCollection(“Xdata”).point(1).HasDataLabels=True.DataLabel.Text=”Sheet1.R1C1”End With7、图表标题、图例和数据表VBA名称：ChartTitle、HasLegend和HasDataTable可以用VBA指定图表标题和图例的位置、文字和文字格式。