vba代码大全

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

Sub 页眉()

'页眉用指定单元格内容

' 2007-4-10

'

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

With ActiveSheet.PageSetup

.LeftHeader = ""

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

Sub zclgzb0418()

'转存到另一工作簿

‘http://club.excelhome.net/dispbbs.asp?boardID=2&ID=234461&page=1&px=0

Dim Mynm$

On Error Resume Next

Application.ScreenUpdating = False

[a3].CurrentRegion.Copy

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

Workbooks.Add

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

Public ywGW, ywSW, ywSwGw, swgw, i%, le1%, Ws()

Public Myarr(), aa, ywJFS, ywGEW, ywBW, ywQW, ywSWW, ywMIL, ywWWW

Sub mydx0419()

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

‘http://club.excelhome.net/dispbbs.asp?BoardID=3&ID=236041&replyID=&skin=0

Dim Do2$, do2dxy$, Do2dxygw$

ywWWW = "": ywMIL = "": ywSWW = "": ywQW = "": ywBW = "": ywGEW = "": ywJFS =

""

Do2 = Replace(Application.Text(Round(ActiveCell + 0.00000001, 2), "#,##0.00"), ".", "")

For i = 1 To le1

Myarr(i) = Mid(Do2, i, 1)

Ws(j) = Myarr(i)

j = j - 1

Next i

For i = 2 To le1

If i = 3 And i <> le1 Then GoTo 1000

If i = 2 Or i = 4 Or i = 7 Or i = 10 Then GoTo 200

If i = 5 Or i = 8 Or i = 11 Then GoTo 500

If i = le1 Then

Call weisu(Ws(i))

ywMIL = ywGW & " MILLION": GoTo 2000

End If

200: If Ws(i) = 0 Then

If Ws(i - 1) <> 0 Then

Call weisu(Ws(i - 1))

If i = 2 And Ws(i - 1) <> 1 Then

ywJFS = " AND CENTS" & ywGW: GoTo 1000

ElseIf i = 2 And Ws(1) = 1 And le1 > 3 Then ywJFS = " AND CENT ONE": GoTo 1000

ElseIf i = 2 And Ws(1) = 1 And le1 < 4 Then ywJFS = " CENT ONE": GoTo 1000

ElseIf i = 7 Then ywQW = ""

ElseIf i = 10 Then ywMIL = ""

End If

Else

Call sw(Ws(i))

If i = 2 Then ywJFS = " AND CENTS" & swgw: GoTo 1000 英文角分

If i = 4 Then ywGEW = swgw: GoTo 1000 '英文个位

If i = 7 Then ywQW = swgw & " THOUSAND": GoTo 1000 '英文千位

If i = 10 Then ywMIL = swgw & " MILLION": GoTo 1000 '英文百万位

End If

If i = 8 And ywQW <> 0 Then ywSWW = ywGW & " HUNDRED": GoTo 1000

If i = 11 And ywMIL = "" Then ywWWW = ywGW & " HUNDRED MILLION": GoTo

1000

If i = 11 And ywMIL <> "" Then ywWWW = ywGW & " HUNDRED": GoTo 1000

Else

If i = 8 Then ywSWW = ""

If i = 11 Then ywWWW = ""

If i = 5 Then ywBW = "": GoTo 1000

End If

End If

Do2 = "UNITED STATES" & ywWWW & ywMIL & ywSWW & ywQW & ywBW &

ywGEW & " DOLLARS" & ywJFS & " ONLY"

2100:

ActiveCell.Offset(, 1).Value = Do2

End Sub

'美元

"": swgw = ""

If ActiveCell = "" Or ActiveCell.Value = 0 Then MsgBox " 请重新选择有美元数字的单元

格！": Exit Sub

Do2 = Replace(Application.Text(Round(ActiveCell + 0.00000001, 2), "#,##0.00"), ".", "")

'MsgBox Do2

Do2 = Replace(Do2, ",", "")

le1 = Len(Do2)

ReDim Myarr(1 To le1)

ReDim Ws(1 To le1)

j = le1

If i = 3 And i <> le1 Then GoTo 1000

If i = 2 Or i = 4 Or i = 7 Or i = 10 Then GoTo 200

If i = 5 Or i = 8 Or i = 11 Then GoTo 500

If i = le1 Then

Call weisu(Ws(i))

If i = 3 Then ywGEW = ywGW: GoTo 2000

If i = 6 Then ywQW = ywGW & " THOUSAND": GoTo 2000

End If

If i = 9 And i = le1 And Ws(i) <> 0 Then

If i = 2 And Ws(i - 1) <> 1 Then

ywJFS = " CENTS" & ywGW: GoTo 1000

ElseIf i = 2 And Ws(1) = 1 And le1 > 3 Then ywJFS = " CENT ONE": GoTo 1000

ElseIf i = 2 And Ws(1) = 1 And le1 < 4 Then

ywJFS = " CENT ONE": GoTo 1000

End If

ElseIf i = 10 Then ywMIL = ""

End If

Else

Call sw(Ws(i))

If i = 4 Then ywGEW = swgw: GoTo 1000 '英文十位个位

If i = 7 Then ywQW = swgw & " THOUSAND": GoTo 1000 '英文千位

If i = 10 Then ywMIL = swgw & " MILLION": GoTo 1000 '英文百万位

End If

500: If i = 5 Or i = 8 Or i = 11 Then

If i = 11 And ywMIL = "" Then ywWWW = ywGW & " HUNDRED MILLION": GoTo

1000

If i = 11 And ywMIL <> "" Then ywWWW = ywGW & " HUNDRED": GoTo 1000

Else

If i = 8 Then ywSWW = ""

If i = 11 Then ywWWW = ""

If i = 5 Then ywBW = "": GoTo 1000

End If

End If

1000: Next i

swgw & " ONLY": GoTo 2100

If Ws(3) = 0 And le1 < 4 Then Do2 = "UNITED STATES" & ywJFS & " ONLY": GoTo

2100