ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 5201|回复: 16

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-6-19 14:30 | 显示全部楼层 |阅读模式
本帖最后由 VBA万岁 于 2019-6-19 17:14 编辑

这样的数学竖式能用VBA完成就好了贴子及守柔版主的作品中“六十七) 数组运用实例(三则混合运算竖式列表代码) ”的启发,特做了个用VBA在Word中实现四则竖式运算的小程序,分享如下:
该程序的实现思路是这样的:
1、加、减运算的实现方法同守柔版主的作品。
2、乘法运算,在守柔版主代码的基础上增加了以下代码:
......
                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
......
该段代码主要的功能是:用于乘积位数超过10的乘法计算。
3、除法运算,用两种方法实现除号的输入:一是用表格的左、上框线代替;二是用插入域的方法插入根号样的除号。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-19 14:32 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
代码如下:
'* +++++++++++++++++++++++++++++++++++++++
'^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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-19 15:26 | 显示全部楼层
VBA万岁 发表于 2019-6-19 14:32
代码如下:
'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [ThisDocument-ThisDocument ...

'^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
        .Rows(2).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle 'Word±í¸ñÖ®VBA֪ʶ£ºhttp://www.360doc.com/content/15/0331/10/21373269_459498146.shtml
    End With
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-19 16:07 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
VBA万岁 发表于 2019-6-19 15:26
'^The Code CopyIn [Module1]^'
Sub BorderNoneLine() '´Ë¶Î´úÂ&eu ...

'* +++++++++++++++++++++++++++++++++++++++
'^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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-19 16:08 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
VBA万岁 发表于 2019-6-19 16:07
'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [用户窗体-UserForm1]
' '* ------- ...

        Case "÷"
            T1 = TextBox2
            T2 = Int(TextBox1.Value / TextBox2.Value)
            T3 = TextBox1.Value Mod TextBox2.Value
            If OptionButton2.Value = True Then 添加除法前两项
            Set MyTab = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=(Len(T2) + 1) * 2, NumColumns:=L1 + L2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitContent)
            With MyTab
                .Borders(wdBorderTop).LineStyle = wdLineStyleNone
                .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
                .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
                .Borders(wdBorderRight).LineStyle = wdLineStyleNone
                .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
                .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
                For i = Len(CStr(T2)) To 1 Step -1
                    For j = 1 To Len(CStr(T3))
                        .Cell(i * 2 + 2, L1 + L2 - Len(CStr(T3)) - k + j).Range = Mid(T3, j, 1) '注意,由于T3为长整型数据,用科学记数法表示,故求其长度时其前必须加上CStr函数,否则会出错,下同
                    Next j
                    If i < Len(CStr(T2)) Then 'i倒着循环,最终的余数直接加上商最后一位数同除数的乘积,作为倒数第二个余数,并且第二个余数不用左移;其他的余数均为前一个余数舍弃最后一位后同相应商位与除数乘积的和,且相对于前余数左移一位
                        k = k + 1
                        T3 = Int(T3 / 10)
                    End If
                    T3 = T3 + Mid(T2, i, 1) * T1
                    For j = 1 To IIf(Mid(T2, i, 1) = 0, Len(CStr(T3)), Len(CStr(Mid(T2, i, 1) * T1))) '此循环代码若用L2代替“Len(CStr(T3))”,则会出现当商的某一数位为0时,乘以除数后0的个数超过被减数的情况,导致对不整齐
                        .Cell(i * 2 + 1, L1 + L2 - IIf(Mid(T2, i, 1) = 0, Len(CStr(T3)), Len(CStr(Mid(T2, i, 1) * T1))) - k + j).Range = IIf(Mid(T2, i, 1) = 0, 0, Mid(Mid(T2, i, 1) * T1, j, 1))
                        .Cell(i * 2 + 1, L1 + L2 - IIf(Mid(T2, i, 1) = 0, Len(CStr(T3)), Len(CStr(Mid(T2, i, 1) * T1))) - k + j).Range.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
                    Next j
                    .Cell(i * 2 + 1, L1 + L2 - k + 1).Range.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
                    If i = 2 Then
                        For j = L2 + 1 To L1 + L2
                            .Cell(i, j).Range.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
                        Next j
                    End If
                Next i
                For j = 1 To Len(T1)
                    .Cell(2, j).Range = Mid(T1, j, 1)
                Next j
                For j = 1 To Len(TextBox1.Value)
                    .Cell(2, Len(T1) + j).Range = Mid(TextBox1.Value, j, 1)
                Next j
                For j = 1 To Len(T2)
                    .Cell(1, L1 + L2 - Len(T2) + j).Range = Mid(T2, j, 1)
                Next j
                .Cell(2, L2 + 1).Range.Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
                For i = Len(CStr(T2)) To 1 Step -1 '此循环是为了删除所有当商数位为0时所生成的只含有0的各行及其上一行(各余数行);若注释掉该循环,则生成的竖式除法在商存在0数位时,会出现无效行。
                    If Mid(CStr(T2), i, 1) = "0" Then
                        .Rows(i * 2 + 1).Delete
                        .Rows(i * 2).Delete
                    End If
                Next i
                If OptionButton2.Value = True Then .Rows(2).Delete: .Rows(1).Delete
                .Select
            End With
        End Select
        Application.ScreenUpdating = True
    End If
    Selection.MoveDown Unit:=wdLine, Count:=1 '向下移两行以离开插入的表格,以防下一次插入的表嵌入前表中
    Selection.TypeParagraph '另起一段,以防下一次插入的表嵌入前表中
    TextBox1.SetFocus
    TextBox1.SelStart = 0 '【VBA研究】进入文本框后其内容全选:https://blog.csdn.net/iamlaosong/article/details/46865569
    TextBox1.SelLength = Len(TextBox1.Value)
End Sub
'----------------------

Private Sub 添加除法前两项()
    Dim s, e, T1, T12 As Long, i%, st1, st2, st3 As String
    'T1 = "    1    2    3    4    5    6    7    8    9    0"
    'T2 = "1  2  3  4"
    T1 = TextBox1 * 1
    T2 = TextBox2 * 1
    For i = 1 To Len(T1)
        st1 = st1 & "    " & Mid(T1, i, 1)
    Next i
    For i = 1 To Len(T2)
        st2 = st2 & Mid(T2, i, 1) & "  "
    Next i
    st2 = Mid(st2, 1, Len(st2) - 2)
    For i = 1 To Len(Int(T1 / T2))
        st3 = st3 & "    " & Mid(Int(T1 / T2), i, 1)
    Next i
    For i = 1 To Len(st2 & st1) - Len(st3) + Len(T2 & T1) - Len(Int(T1 / T2)) + 5 '每个数字占两个空格字符的长,所以第一行(商行)中需补上的空格数为st2 & st1、st3的长度差加上它们的数字个数差再加上5(根号前面的勾占位5个字符长)
        st3 = " " & st3
    Next i
    s = Selection.Start
    ActiveDocument.Range(Start:=s, End:=s).InsertAfter vbCrLf & st2 & st1 & vbCrLf 'vb获取word光标位置并插入文字:https://zhidao.baidu.com/question/1732287261637828467.html
    ActiveDocument.Range(Start:=s + Len(st2) + 2, End:=s + Len(st2) + Len(st1) + 2).Select '选择被除数
    On Error Resume Next
    With Selection '输入“厂”形除号,http://club.excelhome.net/thread-61694-1-1.html
        If .End > .Start Then
            Insertvalue = Selection
            .Delete
            Application.Run "InsertFieldChars"
            .InsertAfter "Eq \r(," & Insertvalue & ")" '.InsertAfter "Eq \r(2," & Insertvalue & ")" '输入根号2、3、4等
        End If
        .Fields.ToggleShowCodes
    End With
    ActiveDocument.Range(Start:=s, End:=s).InsertAfter vbCrLf & st3 'Excel VBA 操作 Word(入门篇):https://www.cnblogs.com/Jacklovely/p/6582668.html
    e = Selection.End
    ActiveDocument.Range(Start:=e + Len(st1) + 12, End:=e + Len(st1) + 12).Select '越过根号及其包含的被被数,选择下一行
End Sub

Private Sub CommandButton1_Click()
     TextBox1.Text = Int(Rnd * 100000): TextBox2.Text = Int(Rnd * 100000)
End Sub

Private Sub CommandButton2_Click()
    TextBox1.Text = "": TextBox2.Text = ""
    TextBox1.SetFocus
End Sub

'----------------------
Private Sub TextBox1_Change()
    ListBox1.ListIndex = -1
End Sub

Private Sub TextBox2_Change()
    ListBox1.ListIndex = -1
End Sub

Private Sub OptionButton1_Click()
    ListBox1.ListIndex = -1
End Sub

Private Sub OptionButton2_Click()
    ListBox1.ListIndex = -1
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-19 16:24 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 VBA万岁 于 2019-6-20 11:51 编辑

操作提示:右键→四则混合运算竖式列表。
效果图: 四则混合运算竖式列表.gif

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-19 17:32 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
VBA万岁 发表于 2019-6-19 16:24
操作提示:右键→三则混合运算竖式列表。
效果图:

说明:4、5楼的代码是连在一起作为窗体代码的——因代码太长,超过1万,不被系统允许,所以分开发送。

TA的精华主题

TA的得分主题

发表于 2019-6-19 22:12 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-20 11:40 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
ammyc 发表于 2019-6-19 22:12
好好玩,好好学习,天天向上

原代码中进行除法运算时,前两行的行间距太大,故增加如下代码:
.Rows(1).Select '此句及以下的For循环语句主要是为了将表格之前的两行(商行及根号行)的行间距变为0,否则相隔太远
                For i = 1 To 2 'word vba 控制光标常用代码:https://blog.csdn.net/ssson/article/details/88771194
                    Selection.MoveUp Unit:=wdLine, Count:=1 '光标上移两行
                    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
                    Selection.MoveEnd Unit:=wdLine, Count:=1
                    Selection.ParagraphFormat.SpaceAfter = 0 '行间距置0,该句由录制宏得到
                Next i

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-20 12:30 | 显示全部楼层
VBA万岁 发表于 2019-6-19 17:32
说明:4、5楼的代码是连在一起作为窗体代码的——因代码太长,超过1万,不被系统允许,所以分开发送。

        Case "÷"
            T1 = TextBox2
            T2 = Int(TextBox1.Value / TextBox2.Value)
            T3 = TextBox1.Value Mod TextBox2.Value
            If OptionButton2.Value = True Then 添加除法前两项
            Set MyTab = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=(Len(T2) + 1) * 2, NumColumns:=L1 + L2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitContent)
            With MyTab
                BorderNoneLine
                For i = Len(CStr(T2)) To 1 Step -1
                    For j = 1 To Len(CStr(T3))
                        .Cell(i * 2 + 2, L1 + L2 - Len(CStr(T3)) - k + j).Range = Mid(T3, j, 1) '注意,由于T3为长整型数据,用科学记数法表示,故求其长度时其前必须加上CStr函数,否则会出错,下同
                    Next j
                    If i < Len(CStr(T2)) Then 'i倒着循环,最终的余数直接加上商最后一位数同除数的乘积,作为倒数第二个余数,并且第二个余数不用左移;其他的余数均为前一个余数舍弃最后一位后同相应商位与除数乘积的和,且相对于前余数左移一位
                        k = k + 1
                        T3 = Int(T3 / 10)
                    End If
                    T3 = T3 + Mid(T2, i, 1) * T1
                    For j = 1 To IIf(Mid(T2, i, 1) = 0, Len(CStr(T3)), Len(CStr(Mid(T2, i, 1) * T1))) '此循环代码若用L2代替“Len(CStr(T3))”,则会出现当商的某一数位为0时,乘以除数后0的个数超过被减数的情况,导致对不整齐
                        .Cell(i * 2 + 1, L1 + L2 - IIf(Mid(T2, i, 1) = 0, Len(CStr(T3)), Len(CStr(Mid(T2, i, 1) * T1))) - k + j).Range = IIf(Mid(T2, i, 1) = 0, 0, Mid(Mid(T2, i, 1) * T1, j, 1))
                        .Cell(i * 2 + 1, L1 + L2 - IIf(Mid(T2, i, 1) = 0, Len(CStr(T3)), Len(CStr(Mid(T2, i, 1) * T1))) - k + j).Range.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
                    Next j
                    .Cell(i * 2 + 1, L1 + L2 - k + 1).Range.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
                    If i = 2 Then
                        For j = L2 + 1 To L1 + L2
                            .Cell(i, j).Range.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
                        Next j
                    End If
                Next i
                For j = 1 To Len(T1)
                    .Cell(2, j).Range = Mid(T1, j, 1)
                Next j
                For j = 1 To Len(TextBox1.Value)
                    .Cell(2, Len(T1) + j).Range = Mid(TextBox1.Value, j, 1)
                Next j
                For j = 1 To Len(T2)
                    .Cell(1, L1 + L2 - Len(T2) + j).Range = Mid(T2, j, 1)
                Next j
                .Cell(2, L2 + 1).Range.Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
                For i = Len(CStr(T2)) To 1 Step -1 '此循环是为了删除所有当商数位为0时所生成的只含有0的各行及其上一行(各余数行);若注释掉该循环,则生成的竖式除法在商存在0数位时,会出现无效行。
                    If Mid(CStr(T2), i, 1) = "0" Then
                        .Rows(i * 2 + 1).Delete
                        .Rows(i * 2).Delete
                    End If
                Next i
                .Rows(1).Select '此句及以下的For循环语句主要是为了将表格之前的两行(商行及根号行)的行间距变为0,否则相隔太远
                For i = 1 To 2 'word vba 控制光标常用代码:https://blog.csdn.net/ssson/article/details/88771194
                    Selection.MoveUp Unit:=wdLine, Count:=1 '光标上移两行
                    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
                    Selection.MoveEnd Unit:=wdLine, Count:=1
                    Selection.ParagraphFormat.SpaceAfter = 0 '行间距置0,该句由录制宏得到
                Next i
                If OptionButton2.Value = True Then .Rows(2).Delete: .Rows(1).Delete
                .Select
            End With
        End Select
        Application.ScreenUpdating = True
    End If
    Selection.MoveDown Unit:=wdLine, Count:=1 '向下移两行以离开插入的表格,以防下一次插入的表嵌入前表中
    Selection.TypeParagraph '另起一段,以防下一次插入的表嵌入前表中
    TextBox1.SetFocus
    TextBox1.SelStart = 0 '【VBA研究】进入文本框后其内容全选:https://blog.csdn.net/iamlaosong/article/details/46865569
    TextBox1.SelLength = Len(TextBox1.Value)
End Sub
'----------------------

Private Sub 添加除法前两项()
    Dim s, e, T1, T12 As Long, i%, st1, st2, st3 As String
    'T1 = "    1    2    3    4    5    6    7    8    9    0"
    'T2 = "1  2  3  4"
    T1 = TextBox1 * 1
    T2 = TextBox2 * 1
    For i = 1 To Len(T1)
        st1 = st1 & "    " & Mid(T1, i, 1)
    Next i
    For i = 1 To Len(T2)
        st2 = st2 & Mid(T2, i, 1) & "  "
    Next i
    st2 = Mid(st2, 1, Len(st2) - 2)
    For i = 1 To Len(Int(T1 / T2))
        st3 = st3 & "    " & Mid(Int(T1 / T2), i, 1)
    Next i
    For i = 1 To Len(st2 & st1) - Len(st3) + Len(T2 & T1) - Len(Int(T1 / T2)) + 5 '每个数字占两个空格字符的长,所以第一行(商行)中需补上的空格数为st2 & st1、st3的长度差加上它们的数字个数差再加上5(根号前面的勾占位5个字符长)
        st3 = " " & st3
    Next i
    s = Selection.Start
    ActiveDocument.Range(Start:=s, End:=s).InsertAfter vbCrLf & st2 & st1 & vbCrLf 'vb获取word光标位置并插入文字:https://zhidao.baidu.com/question/1732287261637828467.html 'Excel VBA 操作 Word(入门篇):https://www.cnblogs.com/Jacklovely/p/6582668.html
    ActiveDocument.Range(Start:=s + Len(st2) + 2, End:=s + Len(st2) + Len(st1) + 2).Select '选择被除数
    On Error Resume Next
    With Selection '输入“厂”形除号,http://club.excelhome.net/thread-61694-1-1.html
        If .End > .Start Then
            Insertvalue = Selection
            .Delete
            Application.Run "InsertFieldChars"
            .InsertAfter "Eq \r(," & Insertvalue & ")" '.InsertAfter "Eq \r(2," & Insertvalue & ")" '输入根号2、3、4等
        End If
        .Fields.ToggleShowCodes
    End With
    ActiveDocument.Range(Start:=s, End:=s).InsertAfter vbCrLf & st3 '若采用将表格第一行复制到竖式除法第一行(商行)的方解决对位不齐的缺点,由于该行前部的空格不再有下面非空单元格的牵扯作用而变窄,反而变得更加不齐,所以复制表格第一行的方法不可用
    e = Selection.End
    ActiveDocument.Range(Start:=e + Len(st1) + 12, End:=e + Len(st1) + 12).Select '越过根号及其包含的被被数,选择下一行
End Sub

Private Sub CommandButton1_Click()
     TextBox1.Text = Int(Rnd * 100000): TextBox2.Text = Int(Rnd * 100000)
End Sub

Private Sub CommandButton2_Click()
    TextBox1.Text = "": TextBox2.Text = ""
    TextBox1.SetFocus
End Sub

'----------------------
Private Sub TextBox1_Change()
    ListBox1.ListIndex = -1
End Sub

Private Sub TextBox2_Change()
    ListBox1.ListIndex = -1
End Sub

Private Sub OptionButton1_Click()
    ListBox1.ListIndex = -1
End Sub

Private Sub OptionButton2_Click()
    ListBox1.ListIndex = -1
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-24 07:56 , Processed in 0.043954 second(s), 9 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表