可以的。万能的vba无所不能。
以前做过的一个任务，截取部分代码供参考！
Public Function Num2Money(ByVal nMoney As Currency) As String '2010.05.04修改
Dim strMoney, strDec, strInt, cNum As String
Dim locDec, i, j As Long '小数点位置
Dim d(4) As String '元以下的单位
Dim t(3) As String '万以下的单位
Dim w(3) As String '阶符
Dim n(9) As String '数字
Dim s(4) As String '用以保存临时转化后的值
On Error Resume Next
d(0) = "": d(1) = "角": d(2) = "分": d(3) = "厘": d(4) = "毫"
t(0) = "": t(1) = "拾": t(2) = "佰": t(3) = "仟"
w(0) = "": w(1) = "元": w(2) = "万": w(3) = "亿"
n(0) = "零": n(1) = "壹": n(2) = "贰": n(3) = "叁": n(4) = "肆":
n(5) = "伍": n(6) = "陆": n(7) = "柒": n(8) = "捌": n(9) = "玖"
If nMoney = 0 Then '为"0"则退出
Num2Money = vbNullString
Exit Function
End If
If nMoney < 0 Then '为负则递归求解
Num2Money = "负" + Num2Money(Abs(nMoney))
Exit Function
End If
strMoney = VBA.Trim(VBA.Str(nMoney))
locDec = InStr(strMoney, ".") '小数点位置
s(0) = ""
If locDec > 0 Then
strDec = VBA.Right(strMoney, Len(strMoney) - locDec)
If strDec <> "" Then '转化小数部分
For i = 1 To Len(strDec)
cNum = VBA.Left(strDec, 1)
strDec = VBA.Right(strDec, Len(strDec) - 1)
If cNum <> "0" Then
s(0) = s(0) & n(Val(cNum)) & d(i)
End If
Next
End If
strInt = VBA.Left(strMoney, locDec - 1) '取整数部分的值
Else
strInt = strMoney
End If
'考虑到VB中货币型变量的范围,不超过 "1000万亿". & _
(-922,337,203,685,477.5808 ~ 922,337,203,685,477.5807)
For i = 0 To Len(strInt) / 4 '每4个数字一组进行转换
s(i + 1) = ""
For j = 0 To 3
If strInt <> "" Then
cNum = VBA.Right(strInt, 1) '取末位数
strInt = VBA.Left(strInt, Len(strInt) - 1)
If cNum <> "0" Then '不为零则加单位
s(i + 1) = n(Val(cNum)) & t(j) & s(i + 1)
Else
s(i + 1) = n(Val(cNum)) & s(i + 1)
End If
End If '删除重复的"零"
s(i + 1) = Replace(s(i + 1), "零零", "零")
Next
If VBA.Right(s(i + 1), 1) = "零" Then '删除末位的"零"
s(i + 1) = VBA.Left(s(i + 1), Len(s(i + 1)) - 1)
End If
Next
Num2Money = ""
For i = 0 To 2 '连接整数位
Num2Money = Num2Money & s(3 - i) & IIf(VBA.Trim(s(3 - i)) = vbNullString, vbNullString, w(3 - i))
Next
Dim NumTrim2Money As String
'加上"元"
If VBA.Trim(Num2Money) <> vbNullString And VBA.Right(Num2Money, 1) <> "元" Then
NumTrim2Money = Num2Money & "元"
End If
'若无小数则加应加上"整"
If VBA.Trim(s(0)) = vbNullString Then
Num2Money = Num2Money & "整"
Else
Num2Money = Num2Money & s(0)
End If
If VBA.Right(Num2Money, 1) <> "分" And VBA.Right(Num2Money, 1) <> "整" Then
Num2Money = Num2Money & "整"
End If
If VBA.Right(VBA.Trim(Num2Money), 1) = "分" And VBA.Left(VBA.Right(VBA.Trim(Num2Money), 3), 1) = "元" Then
Num2Money = VBA.Left(VBA.Trim(Num2Money), Len(VBA.Trim(Num2Money)) - 2) & "零" & VBA.Right(VBA.Trim(Num2Money), 2)
End If
End Function
Private Sub 替换文本_市场(bh, lx, qy, dy, lc, mj, qzrq, dqrq, zq, xflb, zj, yj, xm, dh, sfzhm)
Dim 当前路径, 导出文件名, 导出路径文件名 As String
Dim Str1, Str2
Dim tarr(1 To 27, 1 To 2)
当前路径 = ThisWorkbook.Path
导出文件名 = bh & ".doc"
导出文件名2 = bh & ".xlsx"
FileCopy 当前路径 & "\模板\房屋租赁合同.doc", 当前路径 & "\待打印WORD文档\" & 导出文件名
FileCopy 当前路径 & "\模板\承租申请.xlsx", 当前路径 & "\待打印WORD文档\" & 导出文件名2
With Sheets("关键字")
For i = 1 To 27
tarr(i, 1) = .Cells(i + 1, 1)
Next i
End With
tarr(1, 2) = xm
tarr(2, 2) = qy
tarr(3, 2) = dy
tarr(4, 2) = lc
tarr(5, 2) = dh
tarr(6, 2) = sfzhm
tarr(7, 2) = mj
tarr(8, 2) = yj
tarr(9, 2) = Num2Money(yj * 12) '大写总租金
tarr(10, 2) = yj * 12 '小写总租金
Select Case xflb
Case "年"
tarr(11, 2) = 1
tarr(12, 2) = 12
tarr(13, 2) = Num2Money(zj)
tarr(15, 2) = "" '续费日期2
tarr(16, 2) = "" '续费日期3
tarr(17, 2) = "" '续费日期4
tarr(18, 2) = 12 '第一次几个月租金
tarr(19, 2) = "/"
tarr(20, 2) = "/"
tarr(21, 2) = "/"
tarr(22, 2) = Num2Money(zj) '大写第一次租金
tarr(23, 2) = "/" '大写第二次租金
tarr(24, 2) = "/" '大写第三次租金
tarr(25, 2) = "/" '大写第四次租金
Case "半年"
tarr(11, 2) = 2
tarr(12, 2) = 6
tarr(13, 2) = Num2Money(zj)
tarr(15, 2) = Int(qzrq + 183)
tarr(16, 2) = "" '续费日期3
tarr(17, 2) = "" '续费日期4
tarr(18, 2) = 6 '第一次几个月租金
tarr(19, 2) = 6
tarr(20, 2) = "/"
tarr(21, 2) = "/"
tarr(22, 2) = Num2Money(zj) '大写第一次租金
tarr(23, 2) = Num2Money(zj) '大写第二次租金
tarr(24, 2) = "/" '大写第三次租金
tarr(25, 2) = "/" '大写第四次租金
Case "季度"
tarr(11, 2) = 4
tarr(12, 2) = 3
tarr(13, 2) = Num2Money(zj)
tarr(15, 2) = qzrq + 90
tarr(16, 2) = qzrq + 183 '续费日期3
tarr(17, 2) = Int(qzrq + (365 / 4 * 3 + 0.5)) '续费日期4
tarr(18, 2) = 3 '第一次几个月租金
tarr(19, 2) = 3
tarr(20, 2) = 3
tarr(21, 2) = 3
tarr(22, 2) = Num2Money(zj) '大写第一次租金
tarr(23, 2) = Num2Money(zj) '大写第二次租金
tarr(24, 2) = Num2Money(zj) '大写第三次租金
tarr(25, 2) = Num2Money(zj) '大写第四次租金
End Select
tarr(14, 2) = qzrq
tarr(27, 2) = dqrq
If mj = 55 Then
tarr(26, 2) = 3
Else
If mj = 75 Then
tarr(26, 2) = 5
Else
tarr(26, 2) = 6
End If
End If
导出路径文件名 = 当前路径 & "\待打印WORD文档\" & 导出文件名
导出路径文件名2 = 当前路径 & "\待打印WORD文档\" & 导出文件名2
Set wdoc = CreateObject("word.application")
wdoc.Visible = False
With wdoc
.Documents.Open 导出路径文件名
.Visible = True
For i = 1 To 27 '填写文字数据
Str1 = tarr(i, 1)
Str2 = tarr(i, 2)
bj = True
Do While bj
.Selection.HomeKey Unit:=wdStory '光标置于文件首
If .Selection.Find.Execute(Str1) Then '查找到指定字符串
'.Selection.Font.Color = wdColorAutomatic '字符为自动颜色
.Selection.Text = Str2 '替换字符串
Else
bj = False
End If
Loop
Next i
End With
wdoc.Documents.Save
wdoc.Quit
Set wdoc = Nothing
'写入承租申请
'房号 !区域!单元!楼层
'户型 !面积
'承租说明付款方式: !周期!续费日期!续费
Set myb = Workbooks.Open(导出路径文件名2)
Dim xfrq As Date '续费日期
Select Case xflb
Case "年"
xfrq = dqrq
Case "半年"
xfrq = qzrq + 182
Case "季度"
xfrq = qzrq + 91
End Select
With myb.Sheets("sheet1")
.Cells(3, 2) = xm
.Cells(4, 2) = dh
.Cells(5, 2) = sfzhm
.Cells(6, 2) = qzrq
.Cells(7, 2) = dqrq
.Cells(3, 6) = qy & Space(1) & dy & Space(1) & lc
.Cells(4, 6) = mj
.Cells(5, 6) = yj * 12
.Cells(6, 6) = yj
.Cells(7, 6) = ""
.Cells(9, 1) = zq & " " & xfrq & " " & xflb
End With
myb.Save
myb.Close
End Sub
