Excel自编宏大全Word版.docx
- 文档编号:4701415
- 上传时间:2022-12-07
- 格式:DOCX
- 页数:82
- 大小:38.95KB
Excel自编宏大全Word版.docx
《Excel自编宏大全Word版.docx》由会员分享,可在线阅读,更多相关《Excel自编宏大全Word版.docx(82页珍藏版)》请在冰豆网上搜索。
Excel自编宏大全Word版
1,从数据源匹配取数的问题
2,部分字符地址查找
3,多表查询汇总和重复值问题(相同行删除、循环比较)
4,工作表的名称和index号
5,重复值加色
6,统计
7,最大或最小
8,最后一记录(定义动态区域名称、不重复值公式宏、不重复值个数和行数公式宏、加边框宏)
9,大港表格转换
10,筛选尾数
11,对比数据
12,修改批注字体
13,删除合并单元格
14,物品领用报表
15,条件格式设置
16,多表查询,自动筛选法
17,多条件查询累计汇总
18,和值
19,教师安排汇总(循环比较、不重复值)
20,自动着色(不同个数、不同颜色)
21,不重复值的个数及所在行的行数(各个值的个数、行数)
22,分表自动字体格式化
23,自动填充数字
24,导入文本文件
25,累计不变化(部循环)
26,同结构多表统计汇总(Consolidate方法)
27,资产负债表汇总(多工作簿汇总)
28,导出到文本文件
29,角度求和的自定义公式
30,表单输入模板
31,两表间复制与核对
1,从数据源匹配取数的问题
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列数据的行数
Range("a1").Select
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
Else
Range("F1").Select
Selection.CurrentRegion.Select
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
EndIf
100:
Nexty
200:
Nextx
EndSub
2,部分字符地址查找
‘2007/1/30
‘部分字符地址查找.xls
Subbfzfcz()
DimMyrow1AsInteger
DimMyrow2AsInteger
Dimx%,y1%,y2%,gg%
DimAA,BB
OnErrorResumeNext
Range("a2").Select
Selection.CurrentRegion.Select
Myrow1=Selection.Rows.Count
Range("e1").Select
Selection.CurrentRegion.Select
Myrow2=Selection.Rows.Count
gg=2
Forx=2ToMyrow2
AA=Range("e"&x)
Fory1=2ToMyrow1+1
BB=Application.WorksheetFunction.SearchB(AA,Cells(y1,1))
IfBB>0Then
Range("g"&gg)="A"&y1
gg=gg+1
Else
EndIf
BB=0
Nexty1
Fory2=2ToMyrow1+1
BB=Application.WorksheetFunction.SearchB(AA,Cells(y2,2))
IfBB>0Then
Range("g"&gg)="B"&y2
gg=gg+1
Else
EndIf
BB=0
Nexty2
'gg=gg+1
Nextx
EndSub
3,多表查询汇总和重复值问题(相同行删除、循环比较)
Sub宏0204()
'
'见汇总0204.xls
'2007-2-4
'蓝桥玄霜
'大汇总问题
'
DimxAsInteger,yAsInteger
Dimrng1AsRange,tblAsRange
DimnAsInteger
DimMyrow1AsInteger,Myrow2AsInteger
Dimrng2
Application.ScreenUpdating=False
Sheets("汇总").Select'清除总表原有的数据
Range("a1").Select
Settbl=ActiveCell.CurrentRegion
Iftbl.Rows.Count>1Then
tbl.Offset(1,0).Resize(tbl.Rows.Count-1,tbl.Columns.Count).ClearContents
Else
EndIf
n=2
Sheets("使用型号表").Select
Range("a1").Select
Myrow1=[a65536].End(xlUp).Row'A列最下面一行的行数,中间有空格也行
Forx=2ToMyrow1
Sheets("使用型号表").Select
Setrng1=Range("B"&x)'依次把“使用数量”的值赋给rng1变量
rng2=Range("A"&x).Text'把序号里的表格名赋给rng2变量
Ifrng1.Value<>""Then
Sheets("汇总").Cells(1,6).Value=rng1.Value
Sheets(rng2).Select'用表格名选择表格
Range("a1").Select
Myrow2=Selection.CurrentRegion.Rows.Count'数据的行数
Range(Cells(2,2),Cells(Myrow2,5)).Copy'复制这些数据
Sheets("汇总").Activate
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'为下次粘贴数据的行位置
Else
EndIf
Nextx
bcfhz0204'不重复汇总的宏
Application.ScreenUpdating=True
EndSub
Subbcfhz0204()
'不重复汇总
'蓝桥玄霜
'2007-2-4
DimbAsInteger,xAsInteger,yAsInteger,aaAsInteger,yyyAsInteger
DimmincAsRange
Dimrng1AsRange,aAsRange
Dimn1AsInteger,nnAsInteger,Myrow1AsInteger
Dimpp,pp1
OnErrorResumeNext
Sheets("汇总").Select
Range("a1").Select
Myrow1=Selection.CurrentRegion.Rows.Count'A列数据的行数
Setminc=Range("b2:
b"&Myrow1)
Setrng1=Range("m2:
m"&Myrow1)
Range("m2").Select'求重复值个数的辅助列公式
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)
Range("n2").Select'求重复值的辅助列公式
Selection.Formula="=if(iserror(index(minc,match(row(b1),m$2:
m$65536,0))),"""",index(minc,match(row(b1),m$2:
m$65536,0)))"
Selection.AutoFillDestination:
=Range("n2:
n"&b+1),Type:
=xlFillDefault'公式往下复制
Range("n2:
n"&b+1).Select
'以“选择性粘贴”的“数值”粘贴n,m列,因为删除一行后,公式会重新计算'
Selection.Copy
Range("n2").Select
Selection.PasteSpecialPaste:
=xlValues
rng1.Select
Selection.Copy
Range("m2").Select
Selection.PasteSpecialPaste:
=xlValues
Forx=2Tob+1
Seta=Range("n"&x)
aa=Application.WorksheetFunction.CountIf(minc,a)'计算重复值的个数
Range("o"&x).Value=aa
nn=aa
Range("p1")=a
Range("p2").Select'重复值所在行数的数组公式
Selection.FormulaArray="=if($p$1<>"""",if(iserror(small(if(minc=$p$1,row(minc),""""),row(1:
1))),"""",small(if(minc=$p$1,row(minc),""""),row(1:
1))))"
Selection.AutoFillDestination:
=Range("p2:
p"&aa+1),Type:
=xlFillDefault
Range("p2:
p"&aa+1).Select
Selection.Copy
Range("p2").Select
Selection.PasteSpecialPaste:
=xlValues
'以“选择性粘贴”的“数值”粘贴去除公式影响
Fory=2Tonn'在重复值里循环比较
pp=Range("p"&y).Value'将行数赋给变量pp
Foryy=y+1Tonn+1
pp1=Range("p"&yy).Value'将行数赋给变量pp1
Ifpp1=""Then
GoTo100
Else
EndIf
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:
=xlUp
'删除多余的行
Foryyy=yy+1Tonn+1
Range("p"&yyy)=Range("p"&yyy)-1
Nextyyy
Range("p"&yy).Deleteshift:
=xlUp
yy=yy-1:
nn=nn-1
Else
EndIf
Nextyy
100:
Nexty
nn=aa
Range("p1:
P"&aa+1).ClearContents'清除辅助列数据
200:
Nextx
Range("m1").Select
Selection.CurrentRegion.ClearContents'清除辅助列数据
Range("A1").Select'以下在A列加上序号
n1=Selection.CurrentRegion.Rows.Count
Range("A2").Select
ActiveCell.FormulaR1C1="1"
Range("A3").Select
ActiveCell.FormulaR1C1="2"
Range("A2:
A3").Select
Selection.AutoFillDestination:
=Range("A2:
A"&n1),Type:
=xlFillDefault
Range("A2").Select
EndSub
4,工作表的名称和index号
SubSheetsname()
‘见上例的xls
‘2007-2-2
DimShtAsWorksheet
Sheets("使用型号表").Activate
n=2
ForEachShtInActiveWorkbook.Worksheets
IfSht.Name<>"汇总"AndSht.Name<>"使用型号表"Then
ActiveSheet.Range("k"&n)=Sht.Name
ActiveSheet.Range("l"&n)=Sht.Index
n=n+1
Else
EndIf
NextSht
EndSub
5,重复值加色
Sub重复值加色()
'重复值加色.xls
'蓝桥玄霜2007-2-2
'表格中有重复值公式
'
Dimrng1AsRange,dataAsRange
DimbAsInteger
Setrng1=Range("n2:
n117")‘重复值区域
b=Application.WorksheetFunction.Max(rng1)‘重复值个数
Range("B2:
B117").Select
Selection.FormatConditions.Delete
ForX=2Tob+1‘用查找
Selection.FormatConditions.AddType:
=xlCellValue,Operator:
=xlEqual,_
Formula1:
="=$M$"&X
Selection.FormatConditions(X-1).Interior.ColorIndex=3
NextX
EndSub
6,统计
Subtongji()
‘车次统计,见统计月报1.xls
‘Excel论坛
DimMyrow1AsInteger,Myrow2AsInteger
DimShtAsWorksheet,Sht1AsWorksheet
Application.ScreenUpdating=False
OnErrorResumeNext
ForEachShtInActiveWorkbook.Worksheets'AB列空格填充
IfSht.Name<>"月计"Then
Sheets(Sht.Name).Select
Range("a1").Select
Myrow1=[a65536].End(xlUp).Row'A列最下面一行的行数,中间有空格也行
Setrng1=Range(Cells(4,1),Cells(Myrow1-1,2))
rng1.Select
IfIsError(Selection.SpecialCells(xlCellTypeBlanks))Then
GoTo100
Else
Selection.SpecialCells(xlCellTypeBlanks).Select
Range("A5").Activate
Selection.FormulaR1C1="=R[-1]C"
Range("A4").Select
rng1.Select
Selection.Copy
Selection.PasteSpecialPaste:
=xlValues
Application.CutCopyMode=False
Range("A4").Select
EndIf
Else
EndIf
100:
NextSht
Sheets("月计").Select
SetSht1=Sheets("月计")
Range("a1").Select
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("b"&x).Value
Iffa=""Anddao=""Then
GoTo200
Else
EndIf
Forn=1To10
Sheets(n).Activate
Range("a1").Select
Myrow2=[a65536].End(xlUp).Row
Myrow2=Myrow2-1
Fory=4ToMyrow2
fa1=Range("a"&y).Value
dao1=Range("b"&y).Value
Iffa=fa1Anddao=dao1Then
Sht1.Range("d"&x)=Sht1.Range("d"&x)+Range("d"&y)'汇总
Sht1.Range("e"&x)=Sht1.Range("e"&x)+Range("e"&y)
Sht1.Range("f"&x)=Sht1.Range("f"&x)+Range("f"&y)
Sht1.Range("g"&x)=Sht1.Range("g"&x)+Range("g"&y)
Sht1.Range("h"&x)=Sht1.Range("h"&x)+Range("h"&y)
Sht1.Range("i"&x)=Sht1.Range("i"&x)+Range("i"&y)
Sht1.Range("j"&x)=Sht1.Range("j"&x)+Range("j"&y)
Sht1.Range("k"&x)=Sht1.Range("k"&x)+Range("k"&y)
Else
EndIf
Nexty
Nextn
Sheets("月计").Select
200:
Nextx
Sheets("月计").Select
Application.ScreenUpdating=True
EndSub
7,最大或最小
‘Excel论坛
‘最大或最小.xls
SubMaxMin()
Dimrng1AsRange
DimxAsInteger,bAsInteger
Dima(12)
Range("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
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Excel 宏大 Word