[原创]重新打造单元格公式自动填充功能兼工具

这个程序代码：

Option Compare Text '以文本方式比较 Sub AutoFormula() Dim aCell As Cell, Fct As String, Rfct As String, StartRow As Integer, EndRow As Integer Dim StartCol As Byte, EndCol As Byte, i As Byte On Error Resume Next Application.ScreenUpdating = False With Selection If .Information(wdWithInTable) = False Then MsgBox "光标未处于Word表格中!": GoTo 10 StartRow = .Cells(1).RowIndex EndRow = .Cells(.Cells.Count).RowIndex StartCol = .Cells(1).ColumnIndex EndCol = .Cells(.Cells.Count).ColumnIndex Fct = InputBox("请输入选定单元格中首个单元格的公式,以=开头! 注意引用单元格的行(列)号与公式中的引用相一致!") If Fct Like "=[a-z]#*" = False Or Fct = "" Then MsgBox "无效公式!": GoTo 10 If StartCol = EndCol Then For Each aCell In .Cells If aCell.RowIndex = StartRow Then aCell.Formula Formula:=Fct Else Rfct = Replace(Fct, StartRow, aCell.RowIndex) aCell.Formula Formula:=Rfct End If Next ElseIf StartRow = EndRow Then .Tables(1).Cell(StartRow, StartCol).Select .InsertFormula Formula:=Fct For i = StartCol + 1 To EndCol Rfct = Replace(Fct, Chr(StartCol + 96), Chr(i + 96)) .MoveRight unit:=wdCell .InsertFormula Formula:=Rfct Next Else MsgBox "多行多列的单元格选定区域,Word不予支持!" End If End With 10: Exit Sub Application.ScreenUpdating = True End Sub

这是程序注释：

Option Compare Text '以文本方式比较

Sub AutoFormula()

Dim aCell As Cell, Fct As String, Rfct As String, StartRow As Integer, EndRow As Integer

Dim StartCol As Byte, EndCol As Byte, i As Byte

On Error Resume Next'错误处理(忽略错误)

Application.ScreenUpdating = False'关闭屏幕刷新

With Selection

If .Information(wdWithInTable) = False Then MsgBox "光标未处于Word表格中!": GoTo 10'检测选定部分或者单元格是否处于表格中

StartRow = .Cells(1).RowIndex'选定单元格的开始行号

EndRow = .Cells(.Cells.Count).RowIndex'选定单元格的开始列号

StartCol = .Cells(1).ColumnIndex'选定单元格的结束行号

EndCol = .Cells(.Cells.Count).ColumnIndex'选定单元格的结束列号

Fct = InputBox("请输入选定单元格中首个单元格的公式,以=开头! 注意引用单元格的行(列)号与公式中的引用相一致!")

'初步判断公式录入是否正确,如果不正确转入行标签为10的语句

If Fct Like "=[a-z]#*" = False Or Fct = "" Then MsgBox "无效公式!": GoTo 10

If StartCol = EndCol Then'判断是否为同一行中的选定单元格

For Each aCell In .Cells

If aCell.RowIndex = StartRow Then

aCell.Formula Formula:=Fct'填充第一个公式

Else

Rfct = Replace(Fct, StartRow, aCell.RowIndex)

aCell.Formula Formula:=Rfct'根据列号循环填充公式

End If

Next

ElseIf StartRow = EndRow Then'判断是否为同一列中的选定单元格

.Tables(1).Cell(StartRow, StartCol).Select

.InsertFormula Formula:=Fct'填充第一个单元格公式

For i = StartCol + 1 To EndCol

Rfct = Replace(Fct, Chr(StartCol + 96), Chr(i + 96))

.MoveRight unit:=wdCell

.InsertFormula Formula:=Rfct'循环填充公式(将行号与字母转换)

Next

Else

MsgBox "多行多列的单元格选定区域,Word不予支持!"

End If

End With

10: Exit Sub

Application.ScreenUpdating = True'恢复屏幕刷新

End Sub

'后记,细心的大家也许会发现为什么第一个循环与第二个循环不一致,以及上次的一篇贴子中我也谈到的有些电脑上不能通过,经笔者反复试验,当所一个同行单元格中的公式域的BUG.

有兴趣的朋友可以试一下这个代码:(选中某一行)

Sub CheckBug()

Dim i As Cell

For Each i In Selection.Cells

i.Formula Formula:="=123"

Next

End Sub

这是所有图释：

iIf50Nzk.zip (27.73 KB, 下载次数: 71)

代码请自行复制并测试！

相关链接，供大家参考：

http://club.excelhome.net/viewthread.php?tid=52665

http://club.excelhome.net/viewthread.php?tid=59961

抽空重新打造了一翻，对于一些常用公式如： Sum,Abs,Average,Count,Int,Max,Min,Round,以及普通的四则混合运算,乘方和开方等可以直接在对话框中输入。

以下代码，供参考，VBA PASSWORD：shourou

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By 守柔(ShouRou)@ExcelHome 2005-1-24 19:15:55 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Compare Text '以文本方式比较 Sub AutoFormula() Dim FFct As String, aCell As Cell, Fun As String, Fct As String, Rfct As String, StartRow As Integer Dim EndRow As Integer, StartCol As Byte, EndCol As Byte, i As Byte, Fend As Byte On Error Resume Next '错误处理(忽略错误) Application.ScreenUpdating = False '关闭屏幕刷新 With Selection If .Information(wdWithInTable) = False Then MsgBox "光标未处于Word表格中!", vbOKOnly + vbInformation: GoTo 10 '检测选定部分或者单元格是否处于表格中 If .Fields.Count >= 1 Then MsgBox "当前选定单元格中包含域,程序无法继续!", vbOKOnly + vbExclamation, "Warnning": Exit Sub StartRow = .Cells(1).RowIndex '选定单元格的开始行号 EndRow = .Cells(.Cells.Count).RowIndex '选定单元格的开始列号 StartCol = .Cells(1).ColumnIndex '选定单元格的结束行号 EndCol = .Cells(.Cells.Count).ColumnIndex '选定单元格的结束列号 FFct = InputBox("请输入选定单元格中首个单元格的公式,以=开头! 注意引用单元格的行(列)号与公式中的引用相一致!" & Chr(13) & "函数内部或者运算式外部必须带有括号()!") '初步判断公式录入是否正确,如果不正确转入行标签为10的语句 If FFct = "" Then Exit Sub '如果用户按下取消则退出运行 Fend = InStr(FFct, "(") '得到"("的位置 If Fend = 0 Then MsgBox "无论什么算式,必须有配对包括!", vbOKOnly + vbExclamation, "Warnning": Exit Sub Fun = Mid(FFct, 2, Fend - 2) '取得函数 If Fun <> "" Then '如果非空 '检查函数是否正确 If InStr("Sum,Abs,Average,Count,Int,Max,Min,Round", Fun & ",") = 0 Then _ MsgBox "对不起,本程序不支持该公式!本程序支持的公式为:" & Chr(13) & "Sum,Abs,Average,Count,Int,Max,Min,Round", vbOKOnly _ + vbExclamation, "Warnning": Exit Sub End If Fct = Mid(FFct, Fend, Len(FFct) - Fend + 1) '提取需要填充的单元格数据 ' MsgBox Fun ' MsgBox Fct If Fct Like "([a-z]#*)" = False Or Fct = "" Then MsgBox "无效运算式!", vbOKOnly + vbExclamation, "Warnning": GoTo 10 If StartCol = EndCol Then '判断是否为同一行中的选定单元格 For Each aCell In .Cells If aCell.RowIndex = StartRow Then aCell.Formula Formula:="=" & Fun & Fct '填充第一个公式 Else Rfct = Replace(Fct, StartRow, aCell.RowIndex) aCell.Formula Formula:="=" & Fun & Rfct '根据列号循环填充公式 End If Next ElseIf StartRow = EndRow Then '判断是否为同一列中的选定单元格 .Tables(1).Cell(StartRow, StartCol).Select .InsertFormula Formula:="=" & Fun & Fct '填充第一个单元格公式 For i = StartCol + 1 To EndCol Rfct = Replace(Fct, Chr(StartCol + 96), Chr(i + 96)) .MoveRight unit:=wdCell .InsertFormula Formula:="=" & Fun & Rfct '循环填充公式(将行号与字母转换) Next Else MsgBox "多行多列的单元格选定区域,Word不予支持!", vbOKOnly + vbExclamation, "Warnning" End If End With 10: Exit Sub Application.ScreenUpdating = True '恢复屏幕刷新 End Sub '---------------------- Private Sub Document_Close() On Error Resume Next Application.CommandBars("Tables").Controls("AutoFormula").Delete '恢复原有菜单 End Sub '---------------------- Private Sub Document_Open() Dim Half As Byte On Error Resume Next Dim NewButton As CommandBarButton Application.CommandBars("Tables").Controls("AutoFormula").Delete '预防性删除 Half = Int(Application.CommandBars("Tables").Controls.Count / 2) '中间位置 Set NewButton = Application.CommandBars("Tables").Controls.Add(Type:=msoControlButton, Before:=Half) With NewButton .Caption = "AutoFormula" '命令名称 .FaceId = 385 '命令的FaceId .Visible = True '可见 .OnAction = "AutoFormula" '指定响应过程名 End With End Sub '---------------------- Sub ComReset() '重新设置右键菜单,彻底恢复默认设置 Application.CommandBars("Tables").Reset End Sub '----------------------

jXIxvMnH.rar (21.6 KB, 下载次数: 57)

能拿出如此宏大的作品，斑竹的功力可见一斑了。

感谢。

能告诉我什么反应吗？我好分析一下（估计是你没有按照我的要求去做）

另外，所有运算，均要有括号，如：

=sum(a1:d1),

=(a1+b1+c1+d1),正确；=a1+b1+c1+d1，则出错。

字母不分大小写，但应注意为英文标点录入。

不得为嵌套公式，如=sum(a1:c1)+sum(e1:f1)或者=sum(a1+countif(b1:e1))出错。

谢谢fyb0087的测试,以下附件修正了模板文件中的自定义右键菜单中的一些BUG,请下载该附件.

8XQdXSAE.rar (9.16 KB, 下载次数: 66)