基于VBA 和DocVariable 域?qū)崿F(xiàn)合同文檔的自動(dòng)生成

劉鐵生

（唐山三友氯堿有限責(zé)任公司設(shè)備部，唐山063305）

0 引言

Visual Basic for Applications（簡(jiǎn)稱VBA）是新一代標(biāo)準(zhǔn)宏語(yǔ)言，是基于Visual Basic for Windows 發(fā)展而來(lái)的。VBA 是目前可用的最容易學(xué)習(xí)、最容易使用同時(shí)也是最復(fù)雜的應(yīng)用程序自動(dòng)化語(yǔ)言（過(guò)去常常稱為宏語(yǔ)言）之一。OFFICE 用戶可以很容易地將日常工作轉(zhuǎn)換為VBA 程序代碼，使工作自動(dòng)化。VBA 語(yǔ)言的使用，對(duì)于解決工作中的難題、困難，易如反掌。它可以讓復(fù)雜的工作簡(jiǎn)易化，減少不必要的重復(fù)性工作，大大提高我們的工作效率。

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

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

其工作流程如圖1 所示。

圖1 流程圖

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

1 算法實(shí)現(xiàn)

1.1 Word模版準(zhǔn)備

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

以邀請(qǐng)函模版為例說(shuō)明，DocVariable 域代碼的設(shè)置方法。在需要的位置分別插入競(jìng)價(jià)單位、項(xiàng)目名稱、報(bào)價(jià)截止日期的域代碼。如圖2 所示。

圖2 邀請(qǐng)函模版

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

表1

1.2 實(shí)現(xiàn)代碼

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

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

Set wk=ThisWorkbook

Set sh=wk.Sheets（"明細(xì)"）

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

For i=2 To UBound（arr）

項(xiàng)目名稱=arr（i，3）

競(jìng)價(jià)單位=arr（i，1）

報(bào)價(jià)截止日期=arr（i，5）

Next i

變量傳入Word 模版，實(shí)例代碼如下：

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

""&"邀請(qǐng)函.doc"）

With odoc

For Each doc_var In odoc.Variables

doc_var.Delete

Next

.Variables.Add Name:="競(jìng)價(jià)單位"，Value:=競(jìng)價(jià)單位

.Variables.Add Name:="項(xiàng)目名稱"，Value:=項(xiàng)目名稱

.Variables.Add Name:="報(bào)價(jià)截止日期"，Value:=Format（報(bào)價(jià)截止日期，"yyyy 年mm 月dd 日"）

.Fields.Update.

Fields.Unlink

End With

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

If Dir（ThisWorkbook.Path & "" & 項(xiàng)目號(hào)& ""，vbDirecto?ry）= "" Then MkDir（ThisWorkbook.Path & "" & 項(xiàng)目號(hào)&""）

odoc.SaveAs ThisWorkbook.Path & "" & 項(xiàng)目號(hào)& "" & 項(xiàng)目號(hào)&競(jìng)價(jià)單位&"邀請(qǐng)函及回執(zhí).doc"

odoc.Close False

執(zhí)行過(guò)程：點(diǎn)擊對(duì)應(yīng)過(guò)程按鈕即可，借助本機(jī)out?look 程序，直接將邀請(qǐng)函及回執(zhí)以附件形式發(fā)送到競(jìng)價(jià)單位電子郵箱。

圖3 執(zhí)行過(guò)程

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

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

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

③在后續(xù)結(jié)果公示、合同文件生成中，因?yàn)橹袠?biāo)單位的不確定性，會(huì)造成數(shù)據(jù)源不可知的問(wèn)題。

（2）競(jìng)價(jià)會(huì)議紀(jì)要的生成

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

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）

報(bào)價(jià)=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）=報(bào)價(jià)

If T 報(bào)價(jià)＞報(bào)價(jià)Then T 報(bào)價(jià)= 報(bào)價(jià): 擬選定單位= brr（1，z）

Else

d.Add arr（i，4），1

ReDim brr（1 To 8，1 To 1）

報(bào)價(jià)=IIf（arr（i，16）＞0，arr（i，16），IIf（arr（i，15）＞0，arr（i，15），arr（i，14）））:T 報(bào)價(jià)=報(bào)價(jià)

brr（1，1）= arr（i，1）: brr（2，1）= 報(bào)價(jià): 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 功能實(shí)現(xiàn)對(duì)Word 表格數(shù)據(jù)的寫入。

Set odoc = WordApp.Documents.Open（ThisWorkbook.Path &""&"會(huì)議記錄.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）

投標(biāo)單位=brr（1，n）&"、"&投標(biāo)單位

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

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

（3）結(jié)果公示、中標(biāo)通知書、合同審批表及合同的生成

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

讀取供應(yīng)商信息：

mrr=Sheets（"供應(yīng)商"）.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）

開(kāi)戶銀行=nrr（4，1）

賬號(hào)=nrr（5，1）

稅號(hào)=nrr（6，1）

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

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

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

選擇合同文本模版：

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

If 選擇=1 Then

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

Else

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

End If

寫入Word 模版：

With odoc

For Each doc_var In odoc.Variables

doc_var.Delete

Next

.Variables.Add Name:="項(xiàng)目名稱"，Value:=項(xiàng)目名稱

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

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

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

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

.Variables.Add Name:="開(kāi)戶銀行"，Value:=開(kāi)戶銀行

.Variables.Add Name:="賬號(hào)"，Value:=賬號(hào)

.Variables.Add Name:="稅號(hào)"，Value:=稅號(hào)

.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 & "" & 項(xiàng)目號(hào)& ""，vbDirecto?ry）= "" Then MkDir（ThisWorkbook.Path & "" & 項(xiàng)目號(hào)&""）

odoc.SaveAs ThisWorkbook.Path & "" & 項(xiàng)目號(hào)& "" & 項(xiàng)目號(hào)&"合同.doc"

合同金額根據(jù)中標(biāo)金額，進(jìn)行大寫轉(zhuǎn)換：

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]對(duì)應(yīng)"數(shù)字格式→特殊→中文大寫"

s=Replace（s，"-"，"負(fù)"）'替換減號(hào)為 負(fù)

s=Replace（s，"."，"元"）'替換點(diǎn)為 元

i=Len（s）'字符串長(zhǎng)度

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

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

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

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

End Select

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

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 對(duì)象

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ù)實(shí)際情況做選擇外，其他合同文檔均實(shí)現(xiàn)一鍵生成、存檔功能。同時(shí)，各變量也是一次寫入，多次調(diào)用，復(fù)寫效率很高。

（4）合同臺(tái)賬的生成

圖4 運(yùn)行界面及效果

表2

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

2 結(jié)語(yǔ)

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