用VBA在Word中实现四则混合运算竖式列表

VBA万岁

VBA万岁 发表于 2019-6-19 17:32
说明：4、5楼的代码是连在一起作为窗体代码的——因代码太长，超过1万，不被系统允许，所以分开发送。

全部代码：
'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* --------------------------------------------------------------------------
Private Sub Document_Close()
     On Error Resume Next '忽略错误
     '删除右键菜单
     Application.CommandBars("Text").Reset
End Sub
'----------------------
Private Sub Document_Open()
     Dim NewButton As CommandBarButton
     'On Error Resume Next
     Set NewButton = Application.CommandBars("text").Controls.Add(Type:=msoControlButton)
     With NewButton '修改TEXT的右键菜单
         .Caption = "四则混合运算竖式列表"
         .OnAction = "四则混合运算竖式列表"
         .FaceId = 100
        .Visible = True
     End With
End Sub
Sub 四则混合运算竖式列表()
    UserForm1.Show
End Sub

'^The Code CopyIn [Module1]^'
'* --------------------------------------------------------------------------
Sub BorderNoneLine() '此段代码原文中没有，是通过录制的方式修改而成的
    With Selection.Tables(1)
        .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
        .Borders(wdBorderRight).LineStyle = wdLineStyleNone
        .Borders(wdBorderTop).LineStyle = wdLineStyleNone
        .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
        .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
        .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
        .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
        If UserForm1.ListBox1.Value <> "÷" Then .Rows(2).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle 'Word表格之VBA知识：http://www.360doc.com/content/15/0331/10/21373269_459498146.shtml
    End With
End Sub

'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [用户窗体-UserForm1]
' '* --------------------------------------------------------------------------
Option Compare Binary '二进制比较方式
Private Sub UserForm_Initialize()
    ListBox1.AddItem "＋"
    ListBox1.AddItem "－"
    ListBox1.AddItem "×"
    ListBox1.AddItem "÷"
    TextBox1.SetFocus
    OptionButton2.Value = True
End Sub
Private Sub ListBox1_Click()
    Dim T1, T2, T3 As Long, MyTab As Table, n, i, j, k  As Integer, L1, L2, L3 As Byte, ColNumber As Byte
    Dim CF() As Long, MyLenth() As Byte
    On Error Resume Next '忽略错误
    Application.ScreenUpdating = False '关闭屏幕更新
    If Me.TextBox1 <> "" And Me.TextBox2 <> "" And Me.ListBox1.Value <> "" Then '如果两个文本框都不为空且列表框已被选 定
        T1 = Me.TextBox1 * 1 '转换数据
        T2 = Me.TextBox2 * 1 '转换数据
        L1 = Len(CStr(T1)) '转换数据后取长度
        L2 = Len(CStr(T2)) '转换数据后取长度
        Select Case Me.ListBox1.Value '看列表框值
        Case "＋"
            T3 = T1 + T2
            L3 = Len(CStr(T3))
            If L3 >= L2 And L3 >= L1 Then ColNumber = L3 + 1
            If L2 >= L3 And L2 >= L1 Then ColNumber = L2 + 1
            If L1 >= L2 And L1 >= L3 Then ColNumber = L1 + 1
            Set MyTab = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=3, NumColumns:=ColNumber, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitContent)
            With MyTab
                For i = ColNumber To 2 Step -1
                    .Cell(1, i).Range = VBA.IIf(n >= L1, "", Mid(T1, L1 - n, 1))
                    .Cell(2, i).Range = VBA.IIf(n >= L2, "", Mid(T2, L2 - n, 1))
                    .Cell(3, i).Range = VBA.IIf(n >= L3, "", Mid(T3, L3 - n, 1))
                    n = n + 1
                Next
                .Cell(2, 1).Range = "＋"
                .Select
                Call BorderNoneLine
            End With
        Case "－"
            T3 = T1 - T2
            L3 = Len(CStr(T3))
            If L3 >= L2 And L3 >= L1 Then ColNumber = L3 + 1
            If L2 >= L3 And L2 >= L1 Then ColNumber = L2 + 1
            If L1 >= L2 And L1 >= L3 Then ColNumber = L1 + 1
            Set MyTab = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=3, NumColumns:=ColNumber, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitContent)
            With MyTab
                For i = ColNumber To 2 Step -1
                    .Cell(1, i).Range = VBA.IIf(n >= L1, "", Mid(T1, L1 - n, 1))
                    .Cell(2, i).Range = VBA.IIf(n >= L2, "", Mid(T2, L2 - n, 1))
                    .Cell(3, i).Range = VBA.IIf(n >= L3, "", Mid(T3, L3 - n, 1))
                    n = n + 1
                Next
                .Cell(2, 1).Range = "－"
                .Select
                Call BorderNoneLine
            End With
        Case "×"
            T3 = T1 * T2 '先取得两者之积
            ReDim MyLenth(2) '分配 3 个元素的一个数组
            MyLenth(0) = L1 '元素 1 为T1 的长度
            MyLenth(1) = L2 + 1 '元素 2 为T2 并加上 1 的长度(需要在其右侧加上乘 号)
            MyLenth(2) = Len(CStr(T3)) '元素 3 为T3 的长度
            ReDim CF(1)    '分配 2 个元素的数组
            CF(0) = T1 '元素 1 的值为T1
            CF(1) = T2 '元素 2 的值为T2
            For i = 1 To L2 '从 1 到L2 进行循环与T1 的乘积
                ReDim Preserve MyLenth(i + 2) '加上Preserve是保留原来的数 组中的数据
                ReDim Preserve CF(i + 1) '重新定义该数组的上标是可变上标,并保 存原来的元素值
                CF(i + 1) = T1 * Mid(T2, L2 - i + 1, 1) 'CF数组的一个元素值为T1 与T1 的提取值之积(分步乘积)
                CF2 = CF2 / 10 ^ (i - 1) + CF(i + 1)
                MyLenth(i + 2) = Len(CStr(CF(i + 1))) + i - 1 'MyLenth数组的一个 元素值为CF数组中的元素的长度,其主要目的是设置以后的表格中的单元格数量
            Next
            ReDim Preserve CF(L2 + 2) '再分配多一个元素
            CF(L2 + 2) = T1 * T2    '值为两者乘积
            First = LBound(MyLenth) '取得MyLenth数组的下标
            Last = UBound(MyLenth) '取得MyLenth数组的下标
            For k = First To Last - 1 '以下为冒泡排序法,取得该数组中的大长度值,以便确认该定义的表格的大列数,通常情况下应该是T3 长度,但当T2 长 度与T3长度一致时,则应为T2+1 的长度,原因是需要加上一个X号;  '若能实现显示所有的0乘积（见【1】循环），则该For循环语句包括其内嵌循环语就多余了，删除后照样正常运行
                For j = k + 1 To Last
                    If MyLenth(k) > MyLenth(j) Then
                        Temp = MyLenth(j)
                        MyLenth(j) = MyLenth(k)
                        MyLenth(k) = Temp
                    End If
                Next j
            Next k
            j = 0
            ColNumber = MyLenth(Last) '取得该数组中的大值,命名为表格列数值
            Set MyTab = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=2 + 1 + L2, NumColumns:=ColNumber, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitContent) '定义一个表格,表格插入点在当前光标处,行数为T2 长度(L2)+乘数一行+ 被乘数一行+积一行
            With MyTab
                For i = 0 To L2 + 2 '设置一个表格行循环
                    If i + 1 >= 4 And i < L2 + 2 Then '当表格行号在第四行和小于 后一行之间时
                        j = j + 1 '所得数据需要步进一位(右移一个单元格)
                    Else
                        j = 0 '反之则是个位数乘法和后的乘积数据填入,不需要 右移
                    End If
                    If CF(i) = 0 Then '【1】此If语句及其所包含的第一个For循环代码段是本人加上去的，旨在显示所有的0乘积
                        For k = ColNumber To ColNumber - L1 + 1 Step -1 '当第二个乘数某一数位为0时,该For循环代码段不仅显示该数位上的0与第一个乘数各数位相乘后的最右端的0,而且还将其高数位上的各0也显示出来
                            .Cell(i + 1, k - j).Range = 0
                        Next
                    Else
                        For k = ColNumber To 1 Step -1 '设置一个表格列循环
                            If Len(CStr(CF(i))) + k - ColNumber < 1 Then Exit For '字符提取长度小于 1 退出小循环
                            .Cell(i + 1, k - j).Range = Mid(CF(i), Len(CStr(CF(i))) + k - ColNumber, 1) '符合循环条件的单元格中分别被填入指定截取的数字(相当 于从个十百千…)
                        Next
                    End If
                Next
                For j = ColNumber To 1 Step -1 '后加代码,注释掉本循环后则只能进行最终乘积位数不超过10的乘法计算——当最终乘积位数超过10位时，系统均显示为0，此时只能模拟手工对各乘积的各数位上的数进行相加、进位；若各分乘积的位数超过10时，则该循环也不起作用，程序运行的结果只是若干个0占居所有数位
                    For i = 3 To L2 + 2
                        n = n + Mid(.Cell(i, j).Range.Text, 1, 1)
                    Next i
                    .Cell(L2 + 3, j).Range = n Mod 10 '本位
                    n = Int(n / 10) '进位
                Next j
                .Cell(2, ColNumber - IIf(L1 > L2, L1, L2)).Range = "×" '原代码为:.Cell(2, ColNumber - L2).Range = "×" '第二行的数据右侧单元格填入"×"号
                .Select '选定表格
                Call BorderNoneLine '运行无表格过程(从略) '后一行的上边框线设置
                .Rows(L2 + 2 + 1).Borders(wdBorderTop).LineStyle = wdLineStyleSingle
            End With

VBA万岁

VBA万岁 发表于 2019-6-19 17:32
说明：4、5楼的代码是连在一起作为窗体代码的——因代码太长，超过1万，不被系统允许，所以分开发送。

改进后的效果：


附件：
四则混合运算竖式列表六十七118.zip (93.3 KB, 下载次数: 41)

2019-6-20 12:34 上传

点击文件名下载附件

blackttea1

学习下，谢谢

tangqingfu

谢谢楼主分享

wdpfox

高深莫测呀，谢谢分享！

                                        莫愁前路无知己，天下谁人不识君！只道是：海内存知己，天涯若比邻！  

lin220022

谢谢分享！

xinzhu68

楼主辛苦，太详细了，学习学习