Excel自编宏大全Word版Word文件下载.docx
《Excel自编宏大全Word版Word文件下载.docx》由会员分享,可在线阅读,更多相关《Excel自编宏大全Word版Word文件下载.docx(73页珍藏版)》请在冰豆网上搜索。
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
Nextx
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:
b+1).Select
以“选择性粘贴”的“数值”粘贴n,m列,因为删除一行后,公式会重新计算
Selection.Copy
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
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=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"
Nexty
Nextn
‘最大或最小.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))
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=Application.WorksheetFunction.Min(a
(1),a
(2),a(3),a(4),a(5),a(6),a(7),a(