VBA代码全集.pdf
《VBA代码全集.pdf》由会员分享,可在线阅读,更多相关《VBA代码全集.pdf(38页珍藏版)》请在得力文库 - 分享文档赚钱的网站上搜索。
1、VBA 代码全集云南农业大学1 VBA 代码全集云南农业大学2 目录一、引用 .3二、Worksheet_Change事件:.3三、相乘 .5 四、相减 .6 五、高级筛选 .6 六、双击事件 .8七单位汇总(sumif),单条件汇总.10 八、多条件汇总(连接、sumif).1 3 九、多条件汇总、ado.15 十、对账 .16 十一、sql筛选.20 十二、sql连接、交叉汇总.21 十三、select 语句总结 .23 十四、报表(有层次).24 VBA 代码全集云南农业大学3 一、引用相对引用 B4 绝对引用$B$4 混合引用$B4、B$4 F4 进行引用切换,$在字母前面则锁定列,在
2、数字前面则锁定行。二、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 next If Target.Row 3 And Target.Column=2 Then i=Target.Row Cells(i,3)=Application.WorksheetFunction.VLookup(Cells(i,2),Sheets(简码表VB
3、A 代码全集云南农业大学4).Range(b4:c100),2,False)End If End Sub 备查代码:Private Sub Worksheet_Change(ByVal Target As Range)On Error Resume Next If Target.Row 3 And Target.Column=5 Then i=Target.Row Cells(i,6)=Application.WorksheetFunction.VLookup(Cells(i,5),Sheets(类款项).Range(b2:e2000),2,False)Cells(i,7)=Applicati
4、on.WorksheetFunction.VLookup(Cells(i,5),Sheets(类款项).Range(b2:e2000),3,VBA 代码全集云南农业大学5 False)Cells(i,8)=Application.WorksheetFunction.VLookup(Cells(i,5),Sheets(类款项).Range(b2:e2000),4,False)End If End Sub 三、相乘Sub 计算金额()Application.ScreenUpdating=False Dim i As Long Dim irow As Long irow=Range(a3).End(
5、xldown).Row For i=4 To irow Cells(i,3)=Cells(i,1)*Cells(i,2)Next i Application.ScreenUpdating=True End Sub VBA 代码全集云南农业大学6 四、相减Sub 相减()Application.ScreenUpdating=False Range(c3:c10000).ClearContents Dim i As Long Dim irow As Long irow=Range(a5000).End(xlUp).Row For i=3 To irow Cells(i,3)=VBA.Round(C
6、ells(i,1)-Cells(i,2),2)Next i Application.ScreenUpdating=True End Sub 五、高级筛选(工具-宏-录制新宏,宏名改成高级筛选)VBA 代码全集云南农业大学7 Sub 高级筛选()Sheets(业务).Range(A3:I10000).AdvancedFilter Action:=xlFilterCopy,_ CopyToRange:=ActiveCell.Range(A1:B1),Unique:=True End Sub VBA 代码全集云南农业大学8 六、双击事件1.插入-名称-定义(修改名称和引用位置)2查看代码-插入-用户
7、窗体工具箱-多页、列表框-右键属性点击 page1 修改 caption为资产类-点击空白列表框修改rowsource为 box1 依次类推3.业务表-查看代码 Worksheet beforedoubleclick Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range,Cancel As Boolean)If Target.Row 3 And Target.Column=6 Then UserForm1.Show Sheets(初始化).Range(m3)=ActiveCell VBA 代码全集云南农业大学9 ElseIf
8、 Target.Row 3 And Target.Column=7 Then UserForm2.Show End If End Sub 备查代码:Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range,Cancel As Boolean)If Target.Row 3 And Target.Column=6 Then UserForm1.Show Sheets(初始化).Range(c2)=ActiveCell ElseIf Target.Row 3 And Target.Column=7 Then UserForm2.Sh
9、ow Sheets(初始化).Range(f2)=ActiveCell ElseIf Target.Row 3 And Target.Column=8 Then UserForm3.Show End If End Sub 4右键点击 Userform1 查看代码 Listbox1 dbclickPrivate Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row,6)=ListBox1.List(ListBox1.ListIndex,0)Unload Me End
10、 Sub Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row,6)=ListBox1.List(ListBox2.ListIndex,0)Unload Me End Sub Private Sub ListBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row,6)=ListBox1.List(ListBox3.ListIndex,0
11、)Unload Me End Sub Private Sub ListBox4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)VBA 代码全集云南农业大学10 ActiveSheet.Cells(ActiveCell.Row,6)=ListBox1.List(ListBox4.ListIndex,0)Unload Me End Sub Private Sub ListBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)ActiveSheet.Cells(ActiveCell.Row,6)=Lis
12、tBox1.List(ListBox5.ListIndex,0)Unload Me End 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 Me End Sub Userform initialize Private Sub UserForm_Initial
13、ize()Application.ScreenUpdating=False With Sheets(初始化)Sheets(科目表).Range(h2:i10000).AdvancedFilter Action:=xlFilterCopy,_ CriteriaRange:=.Range(m2:m3),CopyToRange:=.Range(n2),Unique:=True End With Application.ScreenUpdating=True End Sub 七单位汇总(sumif),单条件汇总=SUMIF(业务!$D$4:$D$1000,单位汇总!$A15,业务!I$4:I$1000
14、0)VBA 代码全集云南农业大学11 VBA 代码全集云南农业大学12 Sub 单位汇总1()Application.ScreenUpdating=False range(a1:i10000).Clear Cells(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
15、:=True Sheets(业务).Range(A3:J10000).AdvancedFilter Action:=xlFilterCopy,_ CriteriaRange:=Range(G1:G2),CopyToRange:=Range(G3:I3),Unique:=False Dim i As Long Dim irow As Long irow=Range(a3).End(xlDown).Row For i=4 To irow Cells(i,2)=Application.WorksheetFunction.SumIf(Range(g4:g10000),Cells(i,1),Range(
16、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 i Range(g1:i10000).Clear Application.ScreenUpdating=True End Sub VBA 代码全集云南农业大学13 八、多条件汇总(连接、sumif)连接=k4&l4&m4&n4 Vba:Sub 多条件汇总()Application.ScreenUp
17、dating=False Range(a1:p10000).Clear Sheets(业务).Range(D3:G10000).AdvancedFilter Action:=xlFilterCopy,_ CopyToRange:=Range(B3:E3),Unique:=True Sheets(业务).Range(D3:I10000).AdvancedFilter Action:=xlFilterCopy,_ VBA 代码全集云南农业大学14 CopyToRange:=Range(K3:P3),Unique:=False Dim j As Long Dim jrow As Long jrow=
18、Range(k3).End(xlDown).Row For j=4 To jrow Cells(j,10)=Cells(j,11)&Cells(j,12)&Cells(j,13)&Cells(j,14)Next j Dim i As Long Dim irow As Long irow=Range(b3).End(xlDown).Row For i=4 To irow Cells(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)=Appli
19、cation.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 i Range(i3:p10000).Clear Range(a1:a10000).Delete Application.ScreenUpdating=True End
20、 Sub VBA 代码全集云南农业大学15 九、多条件汇总、ado Sub 多条件汇总()Application.ScreenUpdating=False Dim i As Integer Dim strsql As String Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset cnn.Open Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Hdr=Yes;Data Source=&ThisWorkbook.FullName strsql
21、=SELECT 单位,类,款,项,sum(指标数)as 预算股指标,sum(拨款数)as 预算股拨款 from业务$a3:J10000 where 归口=&Range(h2).Value&and 月=&Range(i2).Value&GROUP BY 单位,类,款,项 rst.Open strsql,cnn For i=1 To rst.Fields.Count VBA 代码全集云南农业大学16 Sheets(多条件汇总).Cells(3,i)=rst.Fields(i-1).Name Next i Sheets(多条件汇总).Range(a4).CopyFromRecordset rst r
22、st.Close cnn.Close Set rst=Nothing Set cnn=Nothing Application.ScreenUpdating=True End Sub 十、对账VBA 代码全集云南农业大学17 Sub 预算股()Application.ScreenUpdating=False Dim i As Integer Dim strsql1 As String Dim cnn1 As New ADODB.Connection Dim rst1 As New ADODB.Recordset cnn1.Open Provider=Microsoft.Jet.OLEDB.4.0
23、;Extended Properties=Excel 8.0;Hdr=Yes;Data Source=&ThisWorkbook.FullName strsql1=SELECT 单位,类,款,项,sum(指标数)as 预算股指标 from预算股$a3:m50000 where 归口=&Range(h2).Value&and 月=&Range(i2).Value&GROUP BY 单位,类,款,项 rst1.Open strsql1,cnn1 For i=1 To rst1.Fields.Count Sheets(对帐).Cells(3,i+10)=rst1.Fields(i-1).Name V
24、BA 代码全集云南农业大学18 Next i Sheets(对帐).Range(k4).CopyFromRecordset rst1 rst1.Close cnn1.Close Set rst1=Nothing Set cnn1=Nothing Dim strsql2 As String Dim cnn2 As New ADODB.Connection Dim rst2 As New ADODB.Recordset cnn2.Open Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Hdr=Yes;Data Sour
25、ce=&ThisWorkbook.FullName strsql2=SELECT 单位,类,款,项,sum(指标数)as 专业股指标 from专业股$a3:j50000 where 归口=&Range(h2).Value&and 月=&Range(i2).Value&GROUP BY 单位,类,款,项 rst2.Open strsql2,cnn2 For i=1 To rst2.Fields.Count Sheets(对帐).Cells(3,i+19)=rst2.Fields(i-1).Name Next i Sheets(对帐).Range(t4).CopyFromRecordset rst
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VBA 代码 全集
限制150内