Excel自编宏大全Word版Word文档下载推荐.docx
《Excel自编宏大全Word版Word文档下载推荐.docx》由会员分享，可在线阅读，更多相关《Excel自编宏大全Word版Word文档下载推荐.docx（82页珍藏版）》请在冰豆网上搜索。
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.PasteSpecialPaste:
rng1.Select
Forx=2Tob+1
aa=Application.WorksheetFunction.CountIf（minc,a）'
计算重复值的个数
o"
x）.Value=aa
nn=aa
p1"
）=a
p2"
重复值所在行数的数组公式
Selection.FormulaArray="
=if（$p$1<
if（iserror（small（if（minc=$p$1,row（minc）,"
）,row（1:
1）））,"
small（if（minc=$p$1,row（minc）,"
1））））"
p2:
p"
aa+1）,Type:
=xlFillDefault
aa+1）.Select
以“选择性粘贴”的“数值”粘贴去除公式影响
Fory=2Tonn'
在重复值里循环比较
pp=Range（"
y）.Value'
将行数赋给变量pp
Foryy=y+1Tonn+1
pp1=Range（"
yy）.Value'
将行数赋给变量pp1
Ifpp1="
IfCells（pp,2）=Cells（pp1,2）AndCells（pp,3）=Cells（pp1,3）AndCells（pp,4）=Cells（pp1,4）Then
Cells（pp,5）=Cells（pp,5）+Cells（pp1,5）'
汇总部分
Range（Cells（pp1,1）,Cells（pp1,5））.Deleteshift:
删除多余的行
Foryyy=yy+1Tonn+1
yyy）=Range（"
yyy）-1
Nextyyy
yy）.Deleteshift:
yy=yy-1:
nn=nn-1
Nextyy
p1:
P"
aa+1）.ClearContents'
清除辅助列数据
m1"
Selection.CurrentRegion.ClearContents'
A1"
以下在A列加上序号
n1=Selection.CurrentRegion.Rows.Count
A2"
ActiveCell.FormulaR1C1="
1"
A3"
2"
A2:
n1）,Type:
SubSheetsname（）
‘见上例的xls
‘2007-2-2
DimShtAsWorksheet
Sheets（"
n=2
ForEachShtInActiveWorkbook.Worksheets
IfSht.Name<
AndSht.Name<
ActiveSheet.Range（"
k"
n）=Sht.Name
l"
n）=Sht.Index
n=n+1
NextSht
Sub重复值加色（）
重复值加色.xls
蓝桥玄霜2007-2-2
表格中有重复值公式
Dimrng1AsRange,dataAsRange
DimbAsInteger
n117"
）‘重复值区域
b=Application.WorksheetFunction.Max（rng1）‘重复值个数
B2:
B117"
Selection.FormatConditions.Delete
ForX=2Tob+1‘用查找
Selection.FormatConditions.AddType:
=xlCellValue,Operator:
=xlEqual,_
Formula1:
="
=$M$"
X
Selection.FormatConditions（X-1）.Interior.ColorIndex=3
NextX
Subtongji（）
‘车次统计，见统计月报1.xls
‘Excel论坛
DimShtAsWorksheet,Sht1AsWorksheet
ForEachShtInActiveWorkbook.Worksheets'
AB列空格填充
月计"
Sheets（Sht.Name）.Select
Myrow1=[a65536].End（xlUp）.Row'
Setrng1=Range（Cells（4,1）,Cells（Myrow1-1,2））
IfIsError（Selection.SpecialCells（xlCellTypeBlanks））Then
Selection.SpecialCells（xlCellTypeBlanks）.Select
A5"
=R[-1]C"
A4"
Application.CutCopyMode=False
NextSht
SetSht1=Sheets（"
）
Myrow1=[a65536].End（xlUp）.Row
Myrow1=Myrow1-1
Range（Cells（4,4）,Cells（Myrow1,11））.ClearContents
Forx=4ToMyrow1
fa=Range（"
a"
x）.Value
dao=Range（"
Iffa="
Anddao="
Forn=1To10
Sheets（n）.Activate
Myrow2=[a65536].End（xlUp）.Row
Myrow2=Myrow2-1
Fory=4ToMyrow2
fa1=Range（"
y）.Value
dao1=Range（"
Iffa=fa1Anddao=dao1Then
Sht1.Range（"
d"
x）=Sht1.Range（"
x）+Range（"
y）'
汇总
y）
f"
h"
i"
j"
Nextn
Application.ScreenUpdating=True
‘最大或最小.xls
SubMaxMin（）
Dimrng1AsRange
DimxAsInteger,bAsInteger
Dima（12）
a14"
）.Value="
Forx=1To12
Cells（2,x+3）.Select
Setrng1=Cells（2,x+3）
a（x）=Selection.Value
b=Application.WorksheetFunction.Find（"
/"
rng1）
a（x）=Left（rng1,b）
a（x）=Val（a（x））
Nextx
Mymax=Application.WorksheetFunction.Max（a
（1）,a
（2）,a（3）,a（4）,a（5）,a（6）,a（7）,a（8）,a（9）,a（10）,a（11）,a（12））
Mymin=Applicati
升级会员 