|
|
楼主 |
发表于 2019-6-20 12: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
'^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万岁
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-6-20 14:52
