Excel自编宏大全Word版Word格式文档下载.docx
《Excel自编宏大全Word版Word格式文档下载.docx》由会员分享，可在线阅读，更多相关《Excel自编宏大全Word版Word格式文档下载.docx（82页珍藏版）》请在冰豆网上搜索。
22，分表自动字体格式化
23，自动填充数字
24，导入文本文件
25，累计不变化（内部循环）
26，同结构多表统计汇总（Consolidate方法）
27，资产负债表汇总（多工作簿汇总）
28，导出到文本文件
29，角度求和的自定义公式
30，表单输入模板
31，两表间复制与核对
Sub宏131（）
'
从数据源匹配取数的问题131.xls
2007-1-31
Shizx98
DimaAsRange,Myrng1AsRange,Myrng2AsRange
DimMyrowAsInteger
DimMyrow1AsInteger
DimMyrow2AsInteger
DimMyrow3AsInteger
DimxAsInteger
Worksheets（"
Sheet1"
）.Activate
Range（"
d2"
）.Select
Selection.CurrentRegion.Select
Myrow2=Selection.Rows.Count'
D列数据的行数
a1"
Myrow3=Selection.CurrentRegion.Rows.Count'
AB列数据的行数
SetMyrng1=Range（Cells（2,1）,Cells（Myrow3,1））
SetMyrng2=Range（Cells（2,2）,Cells（Myrow3,2））
Forx=2ToMyrow2+1
Seta=Range（"
D"
&
x）
Fory=1ToMyrow3
IfLen（a）>
7Then
Myrow=Application.WorksheetFunction.Match（a,Myrng1,0）
Else
Myrow=Application.WorksheetFunction.Match（a,Myrng2,0）
EndIf
IfMyrow=0Then
GoTo100
F1"
Myrow1=Selection.Rows.Count
Range（Cells（Myrow+1,1）,Cells（Myrow+1,2））.Select
Selection.CutDestination:
=Range（Cells（Myrow1+1,6）,Cells（Myrow1+1,7））
Selection.DeleteShift:
=xlUp
Myrow=0
MsgBox"
已找到！
"
GoTo200
100:
Nexty
200:
Nextx
EndSub
‘2007/1/30
‘部分字符地址查找.xls
Subbfzfcz（）
Dimx%,y1%,y2%,gg%
DimAA,BB
OnErrorResumeNext
a2"
e1"
Myrow2=Selection.Rows.Count
gg=2
Forx=2ToMyrow2
AA=Range（"
e"
Fory1=2ToMyrow1+1
BB=Application.WorksheetFunction.SearchB（AA,Cells（y1,1））
IfBB>
0Then
g"
gg）="
A"
y1
gg=gg+1
BB=0
Nexty1
Fory2=2ToMyrow1+1
BB=Application.WorksheetFunction.SearchB（AA,Cells（y2,2））
B"
y2
Nexty2
'
gg=gg+1
Sub宏0204（）
见汇总0204.xls
2007-2-4
蓝桥玄霜
大汇总问题
DimxAsInteger,yAsInteger
Dimrng1AsRange,tblAsRange
DimnAsInteger
DimMyrow1AsInteger,Myrow2AsInteger
Dimrng2
Application.ScreenUpdating=False
Sheets（"
汇总"
）.Select'
清除总表原有的数据
Settbl=ActiveCell.CurrentRegion
Iftbl.Rows.Count>
1Then
tbl.Offset（1,0）.Resize（tbl.Rows.Count-1,tbl.Columns.Count）.ClearContents
n=2
使用型号表"
Myrow1=[a65536].End（xlUp）.Row'
A列最下面一行的行数，中间有空格也行
Forx=2ToMyrow1
Setrng1=Range（"
x）'
依次把“使用数量”的值赋给rng1变量
rng2=Range（"
x）.Text'
把序号里的表格名赋给rng2变量
Ifrng1.Value<
>
"
Then
）.Cells（1,6）.Value=rng1.Value
Sheets（rng2）.Select'
用表格名选择表格
Myrow2=Selection.CurrentRegion.Rows.Count'
数据的行数
Range（Cells（2,2）,Cells（Myrow2,5））.Copy'
复制这些数据
Cells（n,2）.PasteSpecial'
粘贴到汇总表
Range（Cells（n,6）,Cells（Myrow2+n-2,6））.Select'
选择F列相同行数
Selection.FormulaR1C1="
=RC[-1]*r1c6"
将使用数量X数量
Range（Cells（n,6）,Cells（Myrow2+n-2,6））.Copy'
Cells（n,5）.Select
Selection.PasteSpecialPaste:
=xlValues
以“选择性粘贴”的“数值”粘贴
Range（Cells（n,6）,Cells（Myrow2+n-2,6））.ClearContents'
清除F列数量
Cells（1,6）.ClearContents
n=n+Myrow2-1'
为下次粘贴数据的行位置
bcfhz0204'
不重复汇总的宏
Application.ScreenUpdating=True
Subbcfhz0204（）
不重复汇总
2007-2-4
DimbAsInteger,xAsInteger,yAsInteger,aaAsInteger,yyyAsInteger
DimmincAsRange
Dimrng1AsRange,aAsRange
Dimn1AsInteger,nnAsInteger,Myrow1AsInteger
Dimpp,pp1
Myrow1=Selection.CurrentRegion.Rows.Count'
A列数据的行数
Setminc=Range（"
b2:
b"
Myrow1）
m2:
m"
m2"
求重复值个数的辅助列公式
Selection.Formula="
=if（（countif（minc,$b2）>
1）*（match（$b2,minc,0）=row（$a1））,count（m$1:
m1）+1,"
）"
Selection.AutoFillDestination:
=rng1,Type:
=xlFillDefault'
公式往下复制
b=Application.WorksheetFunction.Max（rng1）
n2"
求重复值的辅助列公式
=if（iserror（index（minc,match（row（b1）,m$2:
m$65536,0）））,"
index（minc,match（row（b1）,m$2:
m$65536,0）））"
=Range（"
n2:
n"
b+1）,Type:
Range（"
b+1）.Select
以“选择性粘贴”的“数值”粘贴n,m列，因为删除一行后，公式会重新计算'
Selection.Copy
Selection.Paste
升级会员 