自编宏及实例选之二070618.docx

自编宏及实例选之二070618.docx

《自编宏及实例选之二070618.docx》由会员分享，可在线阅读，更多相关《自编宏及实例选之二070618.docx（73页珍藏版）》请在冰豆网上搜索。

自编宏及实例选之二070618

1，页眉用指定单元格内容

Sub页眉（）

'页眉用指定单元格内容

'2007-4-10

'

ActiveSheet.PageSetup.PrintArea="$A$1:

$E$30"

WithActiveSheet.PageSetup

.LeftHeader=""

.CenterHeader=ActiveSheet.Cells（1,3）.Value‘指定单元格C1

'.CenterHeader=ThisWorkbook.FullName‘打印工作簿全名

'.RightHeader=""

EndWith

ActiveWindow.SelectedSheets.PrintPreview

EndSub

2，转存到另一工作簿（指定路径、文件名）

Subzclgzb0418（）

'转存到另一工作簿

‘

DimMynm$

OnErrorResumeNext

Application.ScreenUpdating=False

[a3].CurrentRegion.Copy

Mynm=ThisWorkbook.Path&"\"&[a3].Value

Workbooks.Add

ActiveSheet.Paste

[a1].Activate

ActiveWorkbook.SaveAsFilename:

=Mynm

ActiveWorkbook.Close

Application.ScreenUpdating=True

EndSub

3，数字转美元和沙特里亚尔（阿拉伯数字转英文写法）

PublicywGW,ywSW,ywSwGw,swgw,i%,le1%,Ws（）

PublicMyarr（）,aa,ywJFS,ywGEW,ywBW,ywQW,ywSWW,ywMIL,ywWWW

Submydx0419（）

‘数字转美元里亚尔0506.xls

‘

DimDo2$,do2dxy$,Do2dxygw$

ywWWW="":

ywMIL="":

ywSWW="":

ywQW="":

ywBW="":

ywGEW="":

ywJFS=""

Do2=Replace（Application.Text（Round（ActiveCell+0.00000001,2）,"#,##0.00"）,".",""）

'MsgBoxDo2

Do2=Replace（Do2,",",""）

le1=Len（Do2）

ReDimMyarr（1Tole1）

ReDimWs（1Tole1）

j=le1

Fori=1Tole1

Myarr（i）=Mid（Do2,i,1）

Ws（j）=Myarr（i）

j=j-1

Nexti

Fori=2Tole1

Ifi=3Andi<>le1ThenGoTo1000

Ifi=2Ori=4Ori=7Ori=10ThenGoTo200

Ifi=5Ori=8Ori=11ThenGoTo500

Ifi=le1Then

Callweisu（Ws（i））

Ifi=3ThenywGEW=ywGW:

GoTo2000

Ifi=6ThenywQW=ywGW&"THOUSAND":

GoTo2000

EndIf

Ifi=9Andi=le1AndWs（i）<>0Then

Callweisu（Ws（i））

ywMIL=ywGW&"MILLION":

GoTo2000

EndIf

200:

IfWs（i）=0Then

IfWs（i-1）<>0Then

Callweisu（Ws（i-1））

Ifi=2AndWs（i-1）<>1Then

ywJFS="ANDCENTS"&ywGW:

GoTo1000

ElseIfi=2AndWs

（1）=1Andle1>3ThenywJFS="ANDCENTONE":

GoTo1000

ElseIfi=2AndWs

（1）=1Andle1<4ThenywJFS="CENTONE":

GoTo1000

EndIf

Ifi=4ThenywGEW=ywGW:

GoTo1000

Ifi=7ThenywQW=ywGW&"THOUSAND":

GoTo1000

Ifi=10ThenywMIL=ywGW&"MILLION":

GoTo1000

ElseIfi=2ThenywJFS=""

ElseIfi=4ThenywGEW=""

ElseIfi=7ThenywQW=""

ElseIfi=10ThenywMIL=""

EndIf

Else

Callsw（Ws（i））

Ifi=2ThenywJFS="ANDCENTS"&swgw:

GoTo1000英文角分

Ifi=4ThenywGEW=swgw:

GoTo1000'英文个位

Ifi=7ThenywQW=swgw&"THOUSAND":

GoTo1000'英文千位

Ifi=10ThenywMIL=swgw&"MILLION":

GoTo1000'英文百万位

EndIf

500:

Ifi=5Ori=8Ori=11Then

IfWs（i）<>0Then

Callweisu（Ws（i））

Ifi=5ThenywBW=ywGW&"HUNDRED":

GoTo1000

Ifi=8AndywQW=""ThenywSWW=ywGW&"HUNDREDTHOUSAND":

GoTo1000

Ifi=8AndywQW<>0ThenywSWW=ywGW&"HUNDRED":

GoTo1000

Ifi=11AndywMIL=""ThenywWWW=ywGW&"HUNDREDMILLION":

GoTo1000

Ifi=11AndywMIL<>""ThenywWWW=ywGW&"HUNDRED":

GoTo1000

Else

Ifi=8ThenywSWW=""

Ifi=11ThenywWWW=""

Ifi=5ThenywBW="":

GoTo1000

EndIf

EndIf

1000:

Nexti

2000:

IfWs（3）=1Andle1<4ThenDo2="UNITEDSTATES"&ywGEW&"DOLLAR"&ywJFS&"ONLY":

GoTo2100

IfWs（3）=0Andle1<4ThenDo2="UNITEDSTATES"&"CENTS"&swgw&"ONLY":

GoTo2100

Do2="UNITEDSTATES"&ywWWW&ywMIL&ywSWW&ywQW&ywBW&ywGEW&"DOLLARS"&ywJFS&"ONLY"

2100:

ActiveCell.Offset（,1）.Value=Do2

EndSub

Submydx0506（）

'美元

DimDo2$,do2dxy$,Do2dxygw$

ywWWW="":

ywMIL="":

ywSWW="":

ywQW="":

ywBW="":

ywGEW="":

ywJFS="":

swgw=""

IfActiveCell=""OrActiveCell.Value=0ThenMsgBox"请重新选择有美元数字的单元格！

":

ExitSub

Do2=Replace（Application.Text（Round（ActiveCell+0.00000001,2）,"#,##0.00"）,".",""）

'MsgBoxDo2

Do2=Replace（Do2,",",""）

le1=Len（Do2）

ReDimMyarr（1Tole1）

ReDimWs（1Tole1）

j=le1

Fori=1Tole1

Myarr（i）=Mid（Do2,i,1）

Ws（j）=Myarr（i）

j=j-1

Nexti

Fori=2Tole1

Ifi=3Andi<>le1ThenGoTo1000

Ifi=2Ori=4Ori=7Ori=10ThenGoTo200

Ifi=5Ori=8Ori=11ThenGoTo500

Ifi=le1Then

Callweisu（Ws（i））

Ifi=3ThenywGEW=ywGW:

GoTo2000

Ifi=6ThenywQW=ywGW&"THOUSAND":

GoTo2000

EndIf

Ifi=9Andi=le1AndWs（i）<>0Then

Callweisu（Ws（i））

ywMIL=ywGW&"MILLION":

GoTo2000

EndIf

200:

IfWs（i）=0Then

IfWs（i-1）<>0Then

Callweisu（Ws（i-1））

Ifi=2AndWs（i-1）<>1Then

ywJFS="CENTS"&ywGW:

GoTo1000

ElseIfi=2AndWs

（1）=1Andle1>3ThenywJFS="CENTONE":

GoTo1000

ElseIfi=2AndWs

（1）=1Andle1<4Then

ywJFS="CENTONE":

GoTo1000

EndIf

Ifi=4ThenywGEW=ywGW:

GoTo1000

Ifi=7ThenywQW=ywGW&"THOUSAND":

GoTo1000

Ifi=10ThenywMIL=ywGW&"MILLION":

GoTo1000

ElseIfi=2ThenywJFS=""

ElseIfi=4ThenywGEW=""

ElseIfi=7ThenywQW=""

ElseIfi=10ThenywMIL=""

EndIf

Else

Callsw（Ws（i））

Ifi=2ThenywJFS="CENTS"&swgw:

GoTo1000'英文角分数

Ifi=4ThenywGEW=swgw:

GoTo1000'英文十位个位

Ifi=7ThenywQW=swgw&"THOUSAND":

GoTo1000'英文千位

Ifi=10ThenywMIL=swgw&"MILLION":

GoTo1000'英文百万位

EndIf

500:

Ifi=5Ori=8Ori=11Then

IfWs（i）<>0Then

Callweisu（Ws（i））

Ifi=5ThenywBW=ywGW&"HUNDRED":

GoTo1000

Ifi=8AndywQW=""ThenywSWW=ywGW&"HUNDREDTHOUSAND":

GoTo1000

Ifi=8AndywQW<>0ThenywSWW=ywGW&"HUNDRED":

GoTo1000

Ifi=11AndywMIL=""ThenywWWW=ywGW&"HUNDREDMILLION":

GoTo1000

Ifi=11AndywMIL<>""ThenywWWW=ywGW&"HUNDRED":

GoTo1000

Else

Ifi=8ThenywSWW=""

Ifi=11ThenywWWW=""

Ifi=5ThenywBW="":

GoTo1000

EndIf

EndIf

1000:

Nexti

2000:

IfWs（3）=1Andle1<4AndywJFS<>""ThenDo2="UNITEDSTATES"&ywGEW&"DOLLARAND"&ywJFS&"ONLY":

GoTo2100

IfWs（3）=1Andle1<4AndywJFS=""ThenDo2="UNITEDSTATES"&ywGEW&"DOLLARONLY":

GoTo2100

IfWs（3）=0AndWs

（2）<>0Andle1<4ThenDo2="UNITEDSTATES"&"CENTS"&swgw&"ONLY":

GoTo2100

IfWs（3）=0Andle1<4ThenDo2="UNITEDSTATES"&ywJFS&"ONLY":

GoTo2100

IfWs（3）<>0Andle1<4AndywJFS<>""ThenDo2="UNITEDSTATES"&ywGEW&"DOLLARSAND"&ywJFS&"ONLY":

GoTo2100

IfWs（3）<>0Andle1<4AndywJFS=""ThenDo2="UNITEDSTATES"&ywGEW&"DOLLARSONLY":

GoTo2100

IfywJFS<>""ThenDo2="UNITEDSTATES"&ywWWW&ywMIL&ywSWW&ywQW&ywBW&ywGEW&"DOLLARSAND"&ywJFS&"ONLY":

GoTo2100

Do2="UNITEDSTATES"&ywWWW&ywMIL&ywSWW&ywQW&ywBW&ywGEW&"DOLLARS"&ywJFS&"ONLY"

2100:

ActiveCell.Offset（,1）.Value=Do2

EndSub

Functionweisu（n）‘个位判别

SelectCasen

Case0

weisu=""

Case1

weisu="ONE"

Case2

weisu="TWO"

Case3

weisu="THREE"

Case4

weisu="FOUR"

Case5

weisu="FIVE"

Case6

weisu="SIX"

Case7

weisu="SEVEN"

Case8

weisu="EIGHT"

Case9

weisu="NINE"

EndSelect

ywGW=weisu

EndFunction

Functionsw（n）‘十位判别

SelectCasen

Case0

IfWs

（1）<>0Then

Callweisu（Ws

（1））

swgw=ywGW'个位

Else

swgw=""

EndIf

Case1

Callws10（Ws（i-1））

swgw=ywSwGw'个位十位

CaseElse

IfWs（i-1）<>0Then

Callweisu（Ws（i-1））

Callws20（Ws（i））

swgw=ywSwGw&ywGW'个位十位

Else

Callws20（n）

swgw=ywSwGw'十位

EndIf

EndSelect

EndFunction

Functionws10（n）‘10至19的判别

SelectCasen

Case0

IfWs（i）<>0Then

ws10="TEN"

Else

ws10=""

EndIf

Case1

IfWs（i-1）=0Then

ws10="TEN"

Else

IfWs（i-1）=1Then

ws10="ELEVEN"

EndIf

EndIf

Case2

ws10="TWELEVE"

Case3

ws10="THIRTEEN"

Case4

ws10="FOURTEEN"

Case5

ws10="FIFTEEN"

Case6

ws10="SIXTEEN"

Case7

ws10="SEVENTEEN"

Case8

ws10="EIGHTEEN"

Case9

ws10="NINTEEN"

EndSelect

ywSwGw=ws10

EndFunction

Functionws20（n）‘20至90的判别

SelectCasen

Case2

ws20="TWENTY"

Case3

ws20="THIRTY"

Case4

ws20="FOURTY"

Case5

ws20="FIFTY"

Case6

ws20="SIXTY"

Case7

ws20="SEVENTY"

Case8

ws20="EIGHTY"

Case9

ws20="NINTY"

EndSelect

ywSwGw=ws20

EndFunction

Subsatedx05059（）

'沙特里亚尔

DimDo2$,do2dxy$,Do2dxygw$

ywWWW="":

ywMIL="":

ywSWW="":

ywQW="":

ywBW="":

ywGEW="":

ywJFS=""

IfActiveCell=""OrActiveCell.Value=0ThenMsgBox"请重新选择有里亚尔数字的单元格！

":

ExitSub

Do2=Replace（Application.Text（Round（ActiveCell+0.00000001,2）,"#,##0.00"）,".",""）

Do2=Replace（Do2,",",""）

le1=Len（Do2）

ReDimMyarr（1Tole1）

ReDimWs（1Tole1）

j=le1

Fori=1Tole1

Myarr（i）=Mid（Do2,i,1）

Ws（j）=Myarr（i）

j=j-1

Nexti

Fori=2Tole1

Ifi=3Andi<>le1ThenGoTo1000

Ifi=2Ori=4Ori=7Ori=10ThenGoTo200

Ifi=5Ori=8Ori=11ThenGoTo500

Ifi=le1Then

Callweisu（Ws（i））

Ifi=3ThenywGEW=ywGW:

GoTo2000

Ifi=6ThenywQW=ywGW&"THOUSAND":

GoTo2000

EndIf

Ifi=9Andi=le1AndWs（i）<>0Then

Callweisu（Ws（i））

ywMIL=ywGW&"MILLION":

GoTo2000

EndIf

200:

IfWs（i）=0Then

IfWs（i-1）<>0Then

Callweisu（Ws（i-1））

Ifi=2AndWs（i-1）<>1Then

ywJFS="AND"&ywGW&"HALALA":

GoTo1000

ElseIfi=2AndWs

（1）="1"Andle1>3ThenywJFS="ANDONEHALALA":

GoTo1000

ElseIfi=2AndWs

（1）="1"Andle1<4Then

ywJFS="ONEHALALA":

GoTo1000

EndIf

Ifi=4ThenywGEW=ywGW:

GoTo1000

Ifi=7ThenywQW=ywGW&"THOUSAND":

GoTo1000

Ifi=10ThenywMIL=ywGW&"MILLION":

GoTo1000

ElseIfi=2ThenywJFS=""

ElseIfi=4ThenywGEW=""

ElseIfi=7ThenywQW=""

ElseIfi=10ThenywMIL=""

EndIf

Else

Callsw（Ws（i））