劉鐵生

（唐山三友氯堿有限責任公司設備部，唐山063305）

0 引言

Visual Basic for Applications（簡稱VBA）是新一代標準宏語言，是基于Visual Basic for Windows 發(fā)展而來的。VBA 是目前可用的最容易學習、最容易使用同時也是最復雜的應用程序自動化語言（過去常常稱為宏語言）之一。OFFICE 用戶可以很容易地將日常工作轉換為VBA 程序代碼，使工作自動化。VBA 語言的使用，對于解決工作中的難題、困難，易如反掌。它可以讓復雜的工作簡易化，減少不必要的重復性工作，大大提高我們的工作效率。

DocVariable 域代碼插入到文檔變量分配的字符串。每個文檔具有變量，可以添加和引用通過使用VBA 編程語言的應用程序的集合。此字段使您能夠在文檔中顯示文檔變量的內容。使用快捷鍵：Ctrl+F9，Word 文檔會出現(xiàn)一對對應的大括號{}，中間為灰色，我們在大括號中間輸入{docviarable 變量名}，然后再按F9就可以了。對這個域代碼，我們可以通過Shift+F9 來切換顯示，Word 會交替顯示{docviarable 變量名}和變量值。如果文檔中有多個域代碼，我們就使用Alt+F9來切換顯示。

以單位外委維修項目合同簽訂為例，期間共計產(chǎn)生合同文檔9 項。以前的傳統(tǒng)做法是，每次安排新的合同都需要在模版或上一個合同的基礎上進行手工修改，有關信息還需要在多個文檔來回切換，進行復制粘貼。事實證明此種方法不僅效率低下，出錯率更高。

其工作流程如圖1 所示。

圖1 流程圖

而本文中僅僅需要在Excel 合同臺賬中及時把相應變量信息填寫上即可。變量主要集中在競價單位、競價單位數(shù)量、報價信息、報價截止日期、中標單位、中標金額以及開戶銀行、賬號等，隨著競價程序的進行，變量值通過VBA 代碼計算出來，同時相關文檔被批量生成。在所需文檔生成的同時，合同臺賬也被健全完善，可謂事半功倍，為今后的數(shù)據(jù)分析工作也打下了基礎。

1 算法實現(xiàn)

1.1 Word模版準備

根據(jù)單位制式要求，在原有文檔的基礎上，對變量部分進行改造。主要利用Word 的DocVariable 域功能，通過VBA 代碼實現(xiàn)Excel 和Word 模版之間的數(shù)據(jù)傳遞。這樣做的好處是靈活，適應性強，極大避免了因Word 模版內容的微調，造成程序無法運行。

以邀請函模版為例說明，DocVariable 域代碼的設置方法。在需要的位置分別插入競價單位、項目名稱、報價截止日期的域代碼。如圖2 所示。

圖2 邀請函模版

Excel 合同數(shù)據(jù)明細如表1。

表1

1.2 實現(xiàn)代碼

（1）邀請及回執(zhí)的生成

Excel 數(shù)據(jù)傳入變量，實例代碼如下：

Set wk=ThisWorkbook

Set sh=wk.Sheets（"明細"）

arr=sh.Range（"a1"）.CurrentRegion

For i=2 To UBound（arr）

項目名稱=arr（i，3）

競價單位=arr（i，1）

報價截止日期=arr（i，5）

Next i

變量傳入Word 模版，實例代碼如下：

Set odoc = WordApp.Documents.Open（ThisWorkbook.Path &

""&"邀請函.doc"）

With odoc

For Each doc_var In odoc.Variables

doc_var.Delete

Next

.Variables.Add Name:="競價單位"，Value:=競價單位

.Variables.Add Name:="項目名稱"，Value:=項目名稱

.Variables.Add Name:="報價截止日期"，Value:=Format（報價截止日期，"yyyy 年mm 月dd 日"）

.Fields.Update.

Fields.Unlink

End With

按照文檔命名規(guī)則另存生成文檔到規(guī)定文件夾，實例代碼如下：

If Dir（ThisWorkbook.Path & "" & 項目號& ""，vbDirecto?ry）= "" Then MkDir（ThisWorkbook.Path & "" & 項目號&""）

odoc.SaveAs ThisWorkbook.Path & "" & 項目號& "" & 項目號&競價單位&"邀請函及回執(zhí).doc"

odoc.Close False

執(zhí)行過程：點擊對應過程按鈕即可，借助本機out?look 程序，直接將邀請函及回執(zhí)以附件形式發(fā)送到競價單位電子郵箱。

圖3 執(zhí)行過程

代碼實現(xiàn)的功能，類似Word 郵件合并。但郵件合并功能缺點有以下幾點：

①郵件合并的用法不可避免的又需要人工操作的介入，包括數(shù)據(jù)源的選取，更換；

②在合同明細表打開的情況下郵件合并沖突，影響程序的連續(xù)性。

③在后續(xù)結果公示、合同文件生成中，因為中標單位的不確定性，會造成數(shù)據(jù)源不可知的問題。

（2）競價會議紀要的生成

各競價單位的報價數(shù)據(jù)，填入Excel 表對應的報價列中，然后利用循環(huán)代碼，用以判斷最低價以及最低價單位，以確定為中標候選人。

For i=2 To UBound（arr）

If d.exists（arr（i，4））Then

d（arr（i，4））=d（arr（i，4））+1

z=d（arr（i，4））

ReDim Preserve brr（1 To 8，1 To z）

報價=IIf（arr（i，16）＞0，arr（i，16），IIf（arr（i，15）＞0，arr（i，15），arr（i，14）））

brr（1，z）=arr（i，1）:brr（2，z）=報價

If T 報價＞報價Then T 報價= 報價: 擬選定單位= brr（1，z）

Else

d.Add arr（i，4），1

ReDim brr（1 To 8，1 To 1）

報價=IIf（arr（i，16）＞0，arr（i，16），IIf（arr（i，15）＞0，arr（i，15），arr（i，14）））:T 報價=報價

brr（1，1）= arr（i，1）: brr（2，1）= 報價: brr（3，1）= arr（i，12）:brr（4，1）=arr（i，3）:brr（5，1）=arr（i，13）: brr （6，1）=arr（i，17）:brr（7，1）=arr（i，4）

擬選定單位=brr（1，1）

End If

Next i

利用tables.InsertAfter 功能實現(xiàn)對Word 表格數(shù)據(jù)的寫入。

Set odoc = WordApp.Documents.Open（ThisWorkbook.Path &""&"會議記錄.doc"）

If odoc.tables.Count ＞=1 Then

For n=1 To brr（8，j）

With odoc.tables（1）.cell（n+1，2）.Range

.Delete

.InsertAfter Text:=brr（1，n）

投標單位=brr（1，n）&"、"&投標單位

End With

With odoc.tables（1）.cell（n+1，3）.Range

.Delete

.InsertAfter Text:=arr（n+1，14）

End With

With odoc.tables（1）.cell（n+1，4）.Range

.Delete

.InsertAfter Text:=brr（2，n）

End With

With odoc.tables（1）.cell（n+1，5）.Range

.Delete

.InsertAfter Text:=Format（arr（n+1，19），"0%"）

End With

Next n

End If

投標單位數(shù)量=brr（8，j）

（3）結果公示、中標通知書、合同審批表及合同的生成

以上幾個合同文檔，完全按照設定的時間節(jié)點，去自動生成，不再需要人為干預。其中合同中有關乙方對應開戶行賬號、稅號等信息，也是從名為供應商的Excel 工作表中自動獲??；包括合同大寫金額的轉換，也是通過人民幣大寫轉換函數(shù)來自動轉換的。生成的同時將結果公示、中標通知書發(fā)送至所有競價單位，將合同文本發(fā)送至中標單位。

讀取供應商信息：

mrr=Sheets（"供應商"）.Range（"a1"）.CurrentRegion

ReDim nrr（1 To 12，1 To 1）

For w=2 To UBound（mrr）

If mrr（w，1）=成交單位Then

kk=kk+1

ReDim Preserve nrr（1 To 12，1 To kk）

For ww=1 To 12

nrr（ww，kk）=mrr（w，ww）

Next ww

dd.Add arr（w，1），nrr

End If

Next

單位地址=nrr（2，1）

傳真=nrr（3，1）

電話=nrr（4，1）

開戶銀行=nrr（4，1）

賬號=nrr（5，1）

稅號=nrr（6，1）

大寫金額=RMBcase（Replace（成交金額，"元"，""））

稅率= Application.WorksheetFunction.VLookup（成交單位，

Sheets（"明細"）.Range（"a1:s"&brr（8，1）+1），19，0）

選擇合同文本模版：

選擇=Application.InputBox（"請選擇現(xiàn)場安裝維修還是離線合同？現(xiàn)場安裝維修合同輸入1，離線合同輸入2？"）

If 選擇=1 Then

Set odoc = WordApp.Documents.Open（ThisWorkbook.Path &""&"現(xiàn)場安裝合同樣本1.doc"）

Else

Set odoc = WordApp.Documents.Open（ThisWorkbook.Path &""&"離線設備維修合同樣本2.doc"）

End If

寫入Word 模版：

With odoc

For Each doc_var In odoc.Variables

doc_var.Delete

Next

.Variables.Add Name:="項目名稱"，Value:=項目名稱

.Variables.Add Name:="成交單位"，Value:=成交單位

.Variables.Add Name:="單位地址"，Value:=單位地址

.Variables.Add Name:="傳真"，Value:=IIf（傳真= ""，" "，傳真）

.Variables.Add Name:="電話"，Value:=IIf（電話= ""，" "，電話）

.Variables.Add Name:="開戶銀行"，Value:=開戶銀行

.Variables.Add Name:="賬號"，Value:=賬號

.Variables.Add Name:="稅號"，Value:=稅號

.Variables.Add Name:="成交金額"，Value:=Replace（成交金額，"元"，""）

.Variables.Add Name:="大寫金額"，Value:=大寫金額

.Variables.Add Name:="稅率"，Value:=Format（稅率，"0%"）

.Fields.Update

.Fields.Unlink

End With

保存文件：

If Dir（ThisWorkbook.Path & "" & 項目號& ""，vbDirecto?ry）= "" Then MkDir（ThisWorkbook.Path & "" & 項目號&""）

odoc.SaveAs ThisWorkbook.Path & "" & 項目號& "" & 項目號&"合同.doc"

合同金額根據(jù)中標金額，進行大寫轉換：

Public Function RMBcase（ByVal Num As Double）As String

Dim s As String，i As Long'英文有Lcase、Ucase，所以人民幣

case

s=Application.Text（Format（Num，"0.00"），"[DBNum2]"）

'Format 四舍五入兩位小數(shù)，[DBNum2]對應"數(shù)字格式→特殊→中文大寫"

s=Replace（s，"-"，"負"）'替換減號為 負

s=Replace（s，"."，"元"）'替換點為 元

i=Len（s）'字符串長度

Select Case InStr（1，s，"元"，1）'"元"出現(xiàn)的位置

Case 0:If s="零"Then s=""Else s=s&"元整"'無元：整數(shù)，零為空，整數(shù)為整元

Case i-1:s=s&"角整"'在倒數(shù)第2 位，有角位無分位

Case i-2:s=Left（s，i-1）&"角"&Right（s，1）&"分"'在倒數(shù)第3 位，有角分位

End Select

s=Replace（s，"零元零角"，""）'在大寫中，無零元零角，只有幾元零幾分

s=Replace（s，"零元"，""）'替換的先后順序不能亂

RMBcase=Replace（s，"零角"，"零"）

End Function

發(fā)送郵件：

Sub SendEmail（To 電子郵箱As String，主題As String，At?tachedObject As String）

Dim OutlookObj As Object

Dim OutlookNewMail As Object

'創(chuàng)建Outlook 對象

Set OutlookObj=CreateObject（"Outlook.Application"）

Set OutlookNewMail=OutlookObj.CreateItem（olMailItem）

On Error GoTo SendEmail_Failed

With OutlookNewMail

.To=To 電子郵箱

.Subject=主題

.Attachments.Add AttachedObject'發(fā)送附件

.Send

End With

End Sub

以上代碼除合同模版樣式需根據(jù)實際情況做選擇外，其他合同文檔均實現(xiàn)一鍵生成、存檔功能。同時，各變量也是一次寫入，多次調用，復寫效率很高。

（4）合同臺賬的生成

圖4 運行界面及效果

表2

合同臺賬是伴隨著明細表中合同文檔生成后，自動寫入到合同臺賬表格中的，不需另行復制粘貼，以減少錯誤的發(fā)生。

2 結語

經(jīng)過多次調試和試驗證明，通過以上方法可以方便地利用VBA 實現(xiàn)多文檔批量自動生成。該方法操作簡單，自動化程度非常高，提高了工作效率和工作質量；同時，生成的明細臺賬也為今后更好地實現(xiàn)信息化管理提供了解決思路和便利。