[分享]WORD的公式自动填充代码

守柔

WORD表格中少量、简单、分配合理计算公式使用域计算，也不失为一种好方法至少可以免去在EXCEL中的复制与粘贴工作或者以插入对象的方式进行。

如何使WORD中的公式类似EXCEL中填充那样方便，是本贴进行研究的对象，当然受到WORD资源限制仅能部分类似，但也总算是一种自慰吧，也是对EXCEL不熟悉的网友的一种帮助更是WORD中域功能的一种开发。

显然，它需要有严格的限制，只能在符合数据库特征的表格中进行并且，公式在列中填充时公式中引用的行号是一致的，如最后一列为E列，则必须是类似于E1=A1+B1-C1*D1，即同一行号引用；如果是在行中填充，如最后一行为6， 则必须是类似于A6=A1/A2*A3+A4-A5形式即其中的列号（A）为同一列引用。

但在最终测试过程中我发现了一个奇怪的问题部分机器不完全支持以下代码主要是行中的公式填充。

请在使用之前确认工具/选项/视图/域代码前打勾。

希望能对大家有所裨益。

Sub AutoFormula() Dim RsNum As Integer, Csnum As Byte, ReNum As Integer, CeNum As Byte, i As Integer On Error GoTo ErrorHandle With Selection RsNum = .Information(wdStartOfRangeRowNumber) Csnum = .Information(wdStartOfRangeColumnNumber) ReNum = .Information(wdEndOfRangeRowNumber) CeNum = .Information(wdEndOfRangeColumnNumber) Application.ScreenUpdating = False .Cells(1).Range.Fields(1).Copy .Paste ActiveWindow.View.ShowFieldCodes = True If Csnum = CeNum Then For i = RsNum + 1 To ReNum .Tables(1).Cell(i, CeNum).Range.Find.Execute findtext:=RsNum, replacewith:=i, Replace:=wdReplaceAll Next End If If RsNum = ReNum Then For i = Csnum + 97 To CeNum + 96 .Tables(1).Cell(RsNum, i - 96).Range.Find.Execute findtext:=Chr(Csnum + 96), MatchCase:=False, replacewith:=Chr(i), Replace:=wdReplaceAll Next End If ActiveWindow.View.ShowFieldCodes = False ActiveDocument.Fields.Update Application.ScreenUpdating = True End With Exit Sub ErrorHandle: MsgBox "请检查域公式或者选定区域是否为表格中以及选定区域是否为表格中", vbOKOnly + vbInformation End Sub

办公之星

守柔的研究，真是值得称道。

如意

守柔版主，我真的很配服你，因为我对VBA是一窍不通。有机会一定好好向你学习学习。

不知道可不可以介绍一下你学习VBA的经验。

守柔

如意你好，知你在精英论坛中收获颇丰。

VBA是OFFICE赋于人机对话的一种方式，是将操作后台自动化的一种方式， 是一种面向对象的工作方法，通过VBA，我们可以达到同样的操作，无论是键盘输入还是鼠标操作甚至于音频操作，因为它们都是面向对象的一种工作方法。

VBA是基于Visual Baisc for Applications的一种结构语言学习VBA通常可以从录制宏入门通过不段的学习与锻炼，来完成各种复杂问题的方法。

我想，VBA可以从宏开始学习，对象通常从SELECTION对象开始学习。

但需要指出的是，VBA不是一蹴而就的，它需要有深刻的键盘鼠标操作经验，熟悉前台对象的各种操作方法尔后才能设计出合理的后台操作代码。如果对WORD前台功能的一些对象属性与方法知之甚少想直接进行VBA操作是很难的。

banjinjiu

1. Sub AutoFormula()
   
2. Dim RsNum As Integer, Csnum As Byte, ReNum As Integer, CeNum As Byte, i As Integer
   
3. On Error GoTo ErrorHandle
   
4. With Selection
   
5. RsNum = .Information(wdStartOfRangeRowNumber)
   
6. Csnum = .Information(wdStartOfRangeColumnNumber)
   
7. ReNum = .Information(wdEndOfRangeRowNumber)
   
8. CeNum = .Information(wdEndOfRangeColumnNumber)
   
9. Application.ScreenUpdating = False
   
10. .Cells(1).Range.Fields(1).Copy
    
11. .Paste
    
12. ActiveWindow.View.ShowFieldCodes = True
    
13. If Csnum = CeNum Then
    
14. For i = RsNum + 1 To ReNum
    
15. .Tables(1).Cell(i, CeNum).Range.Find.Execute findtext:=RsNum, replacewith:=i, Replace:=wdReplaceAll
    
16. Next
    
17. End If
    
18. If RsNum = ReNum Then
    
19. For i = Csnum + 97 To CeNum + 96
    
20. .Tables(1).Cell(RsNum, i - 96).Range.Find.Execute findtext:=Chr(Csnum + 96), MatchCase:=False, replacewith:=Chr(i), Replace:=wdReplaceAll
    
21. Next
    
22. End If
    
23. ActiveWindow.View.ShowFieldCodes = False
    
24. ActiveDocument.Fields.Update
    
25. Application.ScreenUpdating = True
    
26. End With
    
27. Exit Sub
    
28. ErrorHandle: MsgBox "请检查域公式或者选定区域是否为表格中以及选定区域是否为表格中", vbOKOnly + vbInformation
    
29. End Sub

复制代码

朔方

工作中真的实用！