|
Option Explicit
Sub TEST1()
Dim wdApp As Word.Application, strFileName$, strPath$, vTemp1, vTemp
Dim ar, br, cr, i&, j&, n&, k&, strSaveName$, dic As Object, vKey
strPath = ThisWorkbook.Path & "\"
strFileName = strPath & "采购模版.docx"
If Dir(strFileName) = "" Then MsgBox "模板文件不存在,请检查!", vbExclamation: Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
ar = Worksheets(2).[A1].CurrentRegion.Value
For i = 2 To UBound(ar)
dic(ar(i, 1)) = dic(ar(i, 1)) & " " & i
Next i
For Each vKey In dic.keys
cr = Split(dic(vKey))
ReDim br(1 To UBound(cr), 1 To UBound(ar, 2) - 1)
For i = 1 To UBound(cr)
For j = 1 To UBound(br, 2)
br(i, j) = ar(cr(i), j + 1)
Next j
Next i
dic(vKey) = br
Next
ar = Worksheets(1).[A1].CurrentRegion.Value
Set wdApp = GetObject(, "Word.Application")
If Err <> 0 Then
Set wdApp = New Word.Application
End If
For i = 2 To UBound(ar)
With wdApp.documents.Open(strFileName)
strSaveName = strPath & ar(i, 1)
For j = 1 To UBound(ar, 2)
With .Content.Find
.ClearFormatting
.Text = "数据" & Format(j, "000")
.Replacement.Text = ar(i, j)
.Execute Replace:=wdReplaceAll
End With
Next j
If dic.Exists(ar(i, 1)) Then
br = dic(ar(i, 1))
With .Tables(1)
For j = 1 To UBound(br) + 1: .Rows.Add: Next
For k = 1 To UBound(br)
For j = 1 To UBound(br, 2)
.Cell(k + 1, j).Range.Text = br(k, j)
Next j
Next k
n = UBound(br) + 2
.Cell(n, 4).Merge .Cell(n, 4).Next
.Cell(n, 2).Range.Text = "合计"
.Cell(n, 3).Range.Text = WorksheetFunction.Sum(Application.Index(br, , 3))
.Cell(n, 4).Range.Text = "CNY" '
vTemp = WorksheetFunction.Sum(Application.Index(br, , 6))
vTemp1 = vTemp
.Cell(n, 5).Range.Text = vTemp
vTemp = digitToDx(CCur(vTemp))
End With
With .Content.Find
.ClearFormatting
.Text = "数据031"
.Execute
If .Found = True Then
.Parent.Text = "人民币" & vTemp & "(¥:" & vTemp1 & "元)"
End If
End With
End If
.SaveAs strSaveName: .Close
End With
Next i
If Err <> 0 Then wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
Beep
End Sub
Function digitToDx(curNum As Currency) As String
Dim toChi$, ar$(), frontChi$, behindChi$, j$, f$
If Val(curNum) = 0 Then digitToDx = "": Exit Function
toChi = WorksheetFunction.Text(Round(Val(curNum), 2) + 0.001, "[DBNUM2]")
ar = Split(toChi, ".")
frontChi = ar(0): behindChi = Left(ar(1), 2)
j = Mid(behindChi, 1, 1)
f = Mid(behindChi, 2, 1)
If f = "零" Then
If j = "零" Then digitToDx = frontChi & "元整"
If j <> "零" Then digitToDx = frontChi & "元" & j & "角"
Else
If j = "零" Then digitToDx = frontChi & "元" & j & f & "分"
If j <> "零" Then digitToDx = frontChi & "元" & j & "角" & f & "分"
End If
End Function
|
评分
-
1
查看全部评分
-
|