VBA代码全集模板.docx
《VBA代码全集模板.docx》由会员分享，可在线阅读，更多相关《VBA代码全集模板.docx（34页珍藏版）》请在冰豆网上搜索。
VBA代码全集模板
一、引用
相对引用B4
绝对引用$B$4
混合引用$B4、B$4
F4进行引用切换，$在字母前面则锁定列，在数字前面则锁定行。
二、Worksheet_Change事件：
1.在单元格中C4=VLOOKUP（B4,简码表!
$B$4:
$C$1000,2,FALSE）
2.Worksheet_Change事件代码：
PrivateSubWorksheet_Change（ByValTargetAsRange）
Onerrorresumenext
IfTarget.Row>3AndTarget.Column=2Then
i=Target.Row
Cells（i,3）=Application.WorksheetFunction.VLookup（Cells（i,2）,Sheets（"简码表"）.Range（"b4:
c100"）,2,False）
EndIf
EndSub
备查代码：
PrivateSubWorksheet_Change（ByValTargetAsRange）
OnErrorResumeNext
IfTarget.Row>3AndTarget.Column=5Then
i=Target.Row
Cells（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）
EndIf
EndSub
三、相乘
Sub计算金额（）
Application.ScreenUpdating=False
DimiAsLong
DimirowAsLong
irow=Range（"a3"）.End（xldown）.Row
Fori=4Toirow
Cells（i,3）=Cells（i,1）*Cells（i,2）
Nexti
Application.ScreenUpdating=True
EndSub
四、相减
Sub相减（）
Application.ScreenUpdating=False
Range（"c3:
c10000"）.ClearContents
DimiAsLong
DimirowAsLong
irow=Range（"a5000"）.End（xlUp）.Row
Fori=3Toirow
Cells（i,3）=VBA.Round（（Cells（i,1）-Cells（i,2））,2）
Nexti
Application.ScreenUpdating=True
EndSub
五、高级筛选（工具-宏-录制新宏，宏名改成高级筛选）
Sub高级筛选（）
Sheets（"业务"）.Range（"A3:
I10000"）.AdvancedFilterAction:
=xlFilterCopy,_
CopyToRange:
=ActiveCell.Range（"A1:
B1"）,Unique:
=True
EndSub
六、双击事件
1.插入-名称-定义（修改名称和引用位置）
2．查看代码-插入-用户窗体
工具箱-多页、列表框-右键属性
点击page1修改caption为资产类-点击空白列表框修改rowsource为box1
依次类推
3.业务表-查看代码Worksheetbeforedoubleclick
PrivateSubWorksheet_BeforeDoubleClick（ByValTargetAsRange,CancelAsBoolean）
IfTarget.Row>3AndTarget.Column=6Then
UserForm1.Show
Sheets（"初始化"）.Range（"m3"）=ActiveCell
ElseIfTarget.Row>3AndTarget.Column=7Then
UserForm2.Show
EndIf
EndSub
备查代码：
PrivateSubWorksheet_BeforeDoubleClick（ByValTargetAsRange,CancelAsBoolean）
IfTarget.Row>3AndTarget.Column=6Then
UserForm1.Show
Sheets（"初始化"）.Range（"c2"）=ActiveCell
ElseIfTarget.Row>3AndTarget.Column=7Then
UserForm2.Show
Sheets（"初始化"）.Range（"f2"）=ActiveCell
ElseIfTarget.Row>3AndTarget.Column=8Then
UserForm3.Show
EndIf
EndSub
4．右键点击Userform1查看代码Listbox1dbclick
PrivateSubListBox1_DblClick（ByValCancelAsMSForms.ReturnBoolean）
ActiveSheet.Cells（ActiveCell.Row,6）=ListBox1.List（ListBox1.ListIndex,0）
UnloadMe
EndSub
PrivateSubListBox2_DblClick（ByValCancelAsMSForms.ReturnBoolean）
ActiveSheet.Cells（ActiveCell.Row,6）=ListBox1.List（ListBox2.ListIndex,0）
UnloadMe
EndSub
PrivateSubListBox3_DblClick（ByValCancelAsMSForms.ReturnBoolean）
ActiveSheet.Cells（ActiveCell.Row,6）=ListBox1.List（ListBox3.ListIndex,0）
UnloadMe
EndSub
PrivateSubListBox4_DblClick（ByValCancelAsMSForms.ReturnBoolean）
ActiveSheet.Cells（ActiveCell.Row,6）=ListBox1.List（ListBox4.ListIndex,0）
UnloadMe
EndSub
PrivateSubListBox5_DblClick（ByValCancelAsMSForms.ReturnBoolean）
ActiveSheet.Cells（ActiveCell.Row,6）=ListBox1.List（ListBox5.ListIndex,0）
UnloadMe
EndSub
见上图
5.插入用户窗体右键点击userform2worksheetdblclick
PrivateSubListBox1_DblClick（ByValCancelAsMSForms.ReturnBoolean）
ActiveSheet.Cells（ActiveCell.Row,7）=ListBox1.List（ListBox1.ListIndex,0）
UnloadMe
EndSub
Userforminitialize
PrivateSubUserForm_Initialize（）
Application.ScreenUpdating=False
WithSheets（"初始化"）
Sheets（"科目表"）.Range（"h2:
i10000"）.AdvancedFilterAction:
=xlFilterCopy,_
CriteriaRange:
=.Range（"m2:
m3"）,CopyToRange:
=.Range（"n2"）,Unique:
=True
EndWith
Application.ScreenUpdating=True
EndSub
七．单位汇总（sumif），单条件汇总=SUMIF（业务!
$D$4:
$D$1000,单位汇总!
$A15,业务!
I$4:
I$10000）
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"）.AdvancedFilterAction:
=xlFilterCopy,_
CopyToRange:
=Range（"A3"）,Unique:
=True
Sheets（"业务"）.Range（"A3:
J10000"）.AdvancedFilterAction:
=xlFilterCopy,_
CriteriaRange:
=Range（"G1:
G2"）,CopyToRange:
=Range（"G3:
I3"）,Unique:
=False
DimiAsLong
DimirowAsLong
irow=Range（"a3"）.End（xlDown）.Row
Fori=4Toirow
Cells（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）
Nexti
Range（"g1:
i10000"）.Clear
Application.ScreenUpdating=True
EndSub
八、多条件汇总（连接、sumif）
连接=k4&l4&m4&n4
Vba：
Sub多条件汇总（）
Application.ScreenUpdating=False
Range（"a1:
p10000"）.Clear
Sheets（"业务"）.Range（"D3:
G10000"）.AdvancedFilterAction:
=xlFilterCopy,_
CopyToRange:
=Range（"B3:
E3"）,Unique:
=True
Sheets（"业务"）.Range（"D3:
I10000"）.AdvancedFilterAction:
=xlFilterCopy,_
CopyToRange:
=Range（"K3:
P3"）,Unique:
=False
DimjAsLong
DimjrowAsLong
jrow=Range（"k3"）.End（xlDown）.Row
Forj=4Tojrow
Cells（j,10）=Cells（j,11）&Cells（j,12）&Cells（j,13）&Cells（j,14）
Nextj
DimiAsLong
DimirowAsLong
irow=Range（"b3"）.End（xlDown）.Row
Fori=4Toirow
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）=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）Nexti
Range（"i3:
p10000"）.Clear
Range（"a1:
a10000"）.Delete
Application.ScreenUpdating=True
EndSub
九、多条件汇总、ado
Sub多条件汇总（）
Application.ScreenUpdating=False
DimiAsInteger
DimstrsqlAsString
DimcnnAsNewADODB.Connection
DimrstAsNewADODB.Recordset
cnn.Open"Provider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties='Excel8.0;Hdr=Yes';DataSource="&ThisWorkbook.FullName
strsql="SELECT单位,类,款,项,sum（指标数）as预算股指标,sum（拨款数）as预算股拨款from[业务$a3:
J10000]where归口='"&Range（"h2"）.Value&"'and月<="&Range（"i2"）.Value&"GROUPBY单位,类,款,项"
rst.Openstrsql,cnn
Fori=1Torst.Fields.Count
Sheets（"多条件汇总"）.Cells（3,i）=rst.Fields（i-1）.Name
Nexti
Sheets（"多条件汇总"）.Range（"a4"）.CopyFromRecordsetrst
rst.Close
cnn.Close
Setrst=Nothing
Setcnn=Nothing
Application.ScreenUpdating=True
EndSub
十、对账
Sub预算股（）
Application.ScreenUpdating=False
DimiAsInteger
Dimstrsql1AsString
Dimcnn1AsNewADODB.Connection
Dimrst1AsNewADODB.Recordset
cnn1.Open"Provider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties='Excel8.0;Hdr=Yes';DataSource="&ThisWorkbook.FullName
strsql1="SELECT单位,类,款,项,sum（指标数）as预算股指标from[预算股$a3:
m50000]where归口='"&Range（"h2"）.Value&"'and月<="&Range（"i2"）.Value&"GROUPBY单位,类,款,项"
rst1.Openstrsql1,cnn1
Fori=1Torst1.Fields.Count
Sheets（"对帐"）.Cells（3,i+10）=rst1.Fields（i-1）.Name
Nexti
Sheets（"对帐"）.Range（"k4"）.CopyFromRecordsetrst1
rst1.Close
cnn1.Close
Setrst1=Nothing
Setcnn1=Nothing
Dimstrsql2AsString
Dimcnn2AsNewADODB.Connection
Dimrst2AsNewADODB.Recordset
cnn2.Open"Provider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties='Excel8.0;Hdr=Yes';DataSource="&ThisWorkbook.FullName
strsql2="SELECT单位,类,款,项,sum（指标数）as专业股指标from[专业股$a3:
j50000]where归口='"&Range（"h2"）.Value&"'and月<="&Range（"i2"）.Value&"GROUPBY单位,类,款,项"
rst2.Openstrsql2,cnn2
Fori=1Torst2.Fields.Count
Sheets（"对帐"）.Cells（3,i+19）=rst2.Fields（i-1）.Name
Nexti
Sheets（"对帐"）.Range（"t4"）.CopyFromRecordsetrst2
rst2.Close
cnn2.Close
Setrst2=Nothing
Setcnn2=Nothing
s=Application.WorksheetFunction.CountA（Range（"k4:
k10000"））+4
Range（"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"）.Select
ActiveSheet.Paste
DimstrsqlAsString
DimcnnAsNewADODB.Connection
DimrstAsNewADODB.Recordset
cnn.Open"Provider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties='Excel8.0;Hdr=Yes';DataSource="&ThisWorkbook.FullName
strsql="SELECT单位,类,款,项,sum（预算股指标）as预算股指标,sum（专业股指标）as专业股指标from[对帐$k3:
p50000]GROUPBY单位,类,款,项"
rst.Openstrsql,cnn
Fori=1Torst.Fields.Count
Sheets（"对帐"）.Cells（3,i）=rst.Fields（i-1）.Name
Nexti
Sheets（"对帐"）.Range（"a4"）.CopyFromRecordsetrst
rst.Close
cnn.Close
Setrst=Nothing
Setcnn=Nothing
Application.ScreenUpdating=True
EndSub
十一、sql筛选
Sub筛选（）
Application.ScreenUpdating=False
DimiAsInteger
DimstrsqlAsString
DimcnnAsNewADODB.Connection
DimrstAsNewADODB.Recordset
cnn.Open"Provider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties='Excel8.0;Hdr=Yes';DataSource="&ThisWorkbook.FullName
strsql="SELECTdistinct单位,类,款,项from[专业$a3:
h10000]"
rst.Openstrsql,cnn
Fori=1Torst.Fields.Count
Sheets（"筛选"）.Cells（3,i）=rst.Fields（i-1）.Name
Nexti
Sheets（"筛选"）.Range（"a4"）.CopyFromRecordsetrst
rst.Close
cnn.Close
Setrst=Nothing
Setcnn=Nothing
Application.ScreenUpdating=True
EndSub
十二、sql连接、交叉汇总
Sub连接（）
Application.ScreenUpdating=False
DimiAsInteger
DimstrsqlAsString
DimcnnAsNewADODB.Connection
DimrstAsNewADODB.Recordset
cnn.Open"Provider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties='Excel8.0;Hdr=Yes';DataSource="&ThisWorkbook.FullName
strsql="SELECT股,月,归口,单位,类,款,项,指标数from[专业$a3:
h10000]unionALLSELECT股,月,归口,单位,类,款,项,指标数from[预算$a3:
l10000]orderby股desc"
rst.Openstrsql,cnn
Fori=1Torst.Fields.Count
Sheets（"连接"
升级会员 