Excel自编宏大全Word版Word格式文档下载.docx

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