Excel自编宏大全Word版.docx

Excel自编宏大全Word版.docx

《Excel自编宏大全Word版.docx》由会员分享，可在线阅读，更多相关《Excel自编宏大全Word版.docx（96页珍藏版）》请在冰豆网上搜索。

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=Application