WPS VBA 最新版本

大家好，欢迎来到IT知识分享网。

 2023.11.22

窗体程序

 Private Sub CommandButton1_Click() 测试 3 End Sub Private Sub CommandButton2_Click() 测试 2 End Sub Private Sub CommandButton3_Click() 测试 1 End Sub Private Sub CommandButton4_Click() 测试 4 End Sub Sub 测试(x As Long) Dim selectedCells As Cells Dim cell As cell Dim cellText As String Dim dataArray() As Variant Dim i As Long Dim tmp As Long Dim num_count As Long Dim err_count As Long '单元格为-计数 Dim num_tmp As Long '判断是否为- Dim eff_num_count As Long '存储实际有效的单元格数 ' 获取选中的单元格 Set selectedCells = Selection.Cells close_autoset '关闭自动调整功能 tmp = 0 num_count = 0 err_count = 0 eff_num_count = 0 i = 1 If selectedCells Is Nothing Then MsgBox "未选中单元格" Exit Sub End If ' 遍历选中的单元格 For Each cell In selectedCells num_tmp = Val(Trim(cell.Range.Text)) If num_tmp = 0 Then ' 计算单元格数量 err_count = err_count + 1 End If num_count = num_count + 1 Next cell eff_num_count = num_count - err_count ' MsgBox num_count ' 设置数组长度 ReDim dataArray(1 To eff_num_count) ' 遍历选中的单元格 For Each cell In selectedCells ' 存取单元格内容 Set cellRange = cell.Range cellRange.End = cellRange.End - 1 cellText = Trim(cellRange.Text) tmp = Val(cellText) If tmp <> 0 Then dataArray(i) = tmp i = i + 1 End If ' MsgBox i Next cell ' MsgBox num_count ' MsgBox dataArray(2) ' 升序排列数组 SortArrayAscending dataArray ' 弹出消息框显示排序后的数组内容 ' MsgBox Join(dataArray, ", ") Dim creat_rows As Long ' 创建单元格 creat_rows = AddRowToSelectedTable(eff_num_count) ' MsgBox creat_rows '调节单元格比例 AdjustColumn_width creat_rows, dataArray If (eff_num_count Mod 2) <> 0 Then Insert_odd x ElseIf (eff_num_count Mod 2) = 0 Then Insert_even x End If End Sub Sub close_autoset() '设置关闭表格的自动调整功能 Dim select_cell As Cells Dim tbl As Table Dim sel_Rang As Range Set select_cell = Selection.Cells Set tbl = select_cell.Parent.Range.Tables(1) tbl.AutoFitBehavior (wdAutoFitFixed) End Sub Sub SortArrayAscending(ByRef arr() As Variant) Dim i As Long Dim j As Long Dim temp As Variant For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(i) > arr(j) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub Function AddRowToSelectedTable(cell_count As Long) As Long Dim selectedTable As Cells Dim selectedCell As cell Dim lastRow As Object Dim cellToMerge As Cells Dim newCells As Range Dim select_cell As Cells Dim row As Long ' MsgBox Selection.Type ' 检查是否有选中的单元格 If Selection.Type = 4 Then ' 获取选中的单元格对象 Set selectedCell = Selection.Cells(1) ' 获取选中单元格所在的表格对象 Set selectedTable = selectedCell.Tables.Parent.Column.Cells ' 存储选中表格的行数 Dim i As Long i = selectedTable.Count ' MsgBox "选中表格的行数：" & i ' 获取表格的最后一行 Set lastRow = selectedTable(i) ' 在表格的最后一行添加一行 lastRow.Select Selection.InsertRowsBelow Set select_cell = Selection.Cells select_cell.Merge ' 设置新行的列数为4 ' With Selection.Tables(1) ' .Columns.Add ' .Columns.Add ' .Columns.Add ' End With ' 计算生成几行，通过判断单元格个数是奇数或者偶数 Dim count_rows As Long count_rows = cell_count \ 2 ' 拆分单元格 If count_rows > 15 Then select_cell.Split NumRows:=15, NumColumns:=4 select_cell.Split NumRows:=count_rows - 15 + 1, NumColumns:=4 ElseIf count_rows <= 15 Then If cell_count Mod 2 = 0 Then select_cell.Split NumRows:=count_rows, NumColumns:=4 Else count_rows = count_rows + 1 select_cell.Split NumRows:=count_rows, NumColumns:=4 ' 提示添加成功 End If End If 'MsgBox "行已成功添加到选中的表格的最后一行，并且包含" & count_rows & "列。" Else ' 如果没有选中单元格，则提示错误 MsgBox "请先选中一个单元格。" End If ' 返回新建单元格的行数，用来单元格调整 AddRowToSelectedTable = count_rows End Function ' 新增用于对多行进行操作，调节列宽 Sub AdjustColumn_width(creat_rows As Long, arr() As Variant) 'creat_rows 为新建行数 Dim k As Long ' 用于确定数组坐标 Dim arr_index As Long arr_index = 1 For k = 1 To creat_rows arr_index = SelectRowOfSelectedCell(arr, arr_index) If Not k = creat_rows Then Selection.Cells(1).Next.Select End If Next k End Sub '分段 ' 调整表格列宽，并在但单元格中填入数据 Function SelectRowOfSelectedCell(arr() As Variant, arr_index As Long) As Long Dim SelectionRow As Object Dim selectedCells As Cells Dim c As cell Dim index As Long Dim percent As Single Set SelectionRow = Selection.Rows(1) SelectionRow.Select Set selectedCells = Selection.Cells index = selectedCells.Count For Each c In selectedCells ' c.Range.Text = arr() ' 当列表为1，2列，存arr(i) 3.4列存arr(i+1) If c.ColumnIndex = 1 Or c.ColumnIndex = 2 Then c.Range.Text = arr(arr_index) If c.ColumnIndex = 2 Then ImportPicturesWithFolder c End If ElseIf c.ColumnIndex = 3 Or c.ColumnIndex = 4 Then If Not arr_index = UBound(arr) Then ' 检查索引是否超出数组的上界 c.Range.Text = arr(arr_index + 1) If c.ColumnIndex = 3 Then ImportPicturesWithFolder c End If End If End If ' MsgBox c.PreferredWidthType ' 设置列宽形式为百分比 c.PreferredWidthType = wdPreferredWidthPercent If c.ColumnIndex = 1 Or c.ColumnIndex = index Then percent = 0.08 SetCellWidth percent, c Else percent = 0.42 SetCellWidth percent, c ' MsgBox c.PreferredWidthType ' MsgBox c.PreferredWidth End If Next c SelectRowOfSelectedCell = arr_index + 2 End Function ' 设置行列比例 Function SetCellWidth(percent As Single, c As cell) As Variant ' Dim tbl As Table Dim total_long As Double ' Set tbl = Selection.Tables(1) ' 假设选中的是表格中的单元格 ' 获取第2行第4列的单元格 ' Dim cell As cell ' Set cell = tbl.Range.Cells(Now_index) ' 取消选中"指定宽度"复选框 c.Select Selection.Cells(1).Select ' Selection.Cells(1).PreferredWidthType = wdPreferredWidthAuto total_long = CalculateTotalWidth ' MsgBox "总长" & total_long ' 设置单元格的宽度为5厘米 Selection.Cells(1).Width = total_long * percent Exit Function End Function '计算表格第一列长度 Function CalculateTotalWidth() As Double Dim totalWidth As Double Dim tbl As Table ' 假设tbl是您要操作的表格对象 Set tbl = ActiveDocument.Tables(1) totalWidth = 0 Dim firstRow As row Set firstRow = tbl.Rows(1) Dim firstCell As cell For Each firstCell In firstRow.Cells totalWidth = totalWidth + firstCell.Width Next firstCell CalculateTotalWidth = totalWidth End Function ' 插入图片 Function ImportPicturesWithFolder(c As cell) As Variant Dim picFolder As FileDialog Dim picPath As String Dim Pic As InlineShape Dim FSO As FileSystemObject Dim PicFolderObj As Folder Dim PicFileObj As File 'Dim selectedCells As Cells 'Dim c As cell Dim insertCount As Integer Set FSO = New FileSystemObject '实例化 FileSystemObject 对象 '选择图片文件夹 Set picFolder = Application.FileDialog(msoFileDialogFolderPicker) With picFolder .Title = "选择图片所在的文件夹" .AllowMultiSelect = False '取消选择文件夹功能 '.Show 'picPath = .SelectedItems(1) ' 可以自行修改图片存放为位置的地址 picPath = "D:\XYZ\Documents\录音" If Right(picPath, 1) <> "\" Then picPath = picPath & "\" End With '获取选中的单元格 'Set selectedCells = Selection.Cells '遍历选中的单元格 'For Each c In selectedCells Dim celText As String ' 逐个单元格读取文本 Set cellRange = c.Range ' 去掉单元格范围最后的换行符 cellRange.End = cellRange.End - 1 ' 输出单元格范围中的文本 ' 用两个双引号来替换单元格内的双引号 cellText = Trim(cellRange.Text) '遍历图片文件夹中的图片文件 Set PicFolderObj = FSO.GetFolder(picPath) For Each PicFileObj In PicFolderObj.Files '处理文件名，将文件名转化为大写并去掉文件后缀 Dim filename As String filename = UCase(PicFileObj.Name) filename = Left(filename, Len(filename) - Len(PicFileObj.Type) + 2) '判断图片文件名是否与表格单元格对应的值一致，忽略大小写 If StrComp(cellText, filename, vbTextCompare) = 0 Then cellRange.Delete '插入图片 Set Pic = c.Range.InlineShapes.AddPicture(filename:=PicFileObj.Path, LinkToFile:=False, SaveWithDocument:=True) '调整图片大小 With Pic .Width = 180 .Height = 100 End With '找到对应的图片文件后跳出循环 Exit For End If Next PicFileObj '统计插入的图片数量 If Not Pic Is Nothing Then insertCount = insertCount + 1 End If 'Next c '如果插入了图片，提示操作成功，否则提示操作失败 'If insertCount > 0 Then 'MsgBox "成功在选中的单元格中插入 " & insertCount & " 张图片！", vbOKOnly + vbInformation, "操作成功" 'Else 'MsgBox "很抱歉，没有找到匹配的图片文件，请检查文件名和单元格内容是否一致！", vbOKOnly + vbExclamation, "操作失败" 'End If End Function Sub Insert_odd(x As Long) '波形图为奇数，使用该段 Dim selectedCell As cell Dim previousCell As cell Dim userInput As String ' 假设您已经选中了要操作的表格中的某一个单元格 Set selectedCell = Selection.Cells(1) ' 获取该单元格所在行的前一列的单元格 Set previousCell = selectedCell.Previous ' 合并选中单元格与前一列单元格 If Not previousCell Is Nothing Then selectedCell.Merge previousCell End If Select Case x Case 1 '单机模式 userInput = InputBox("请输入要插入的文字", "波形图标题", "CH1:输出电压 CH2:电感电流") Case 2 '市电模式 userInput = InputBox("请输入要插入的文字", "波形图标题", "CH1:输出电压 CH2:市电电流") Case 3 userInput = InputBox("请输入要插入的文字", "波形图标题", "CH1:反峰电压") Case 4 userInput = InputBox("请输入要插入的文字", "波形图标题", "CH1:Q1驱动电压 CH2:Q1驱动电压 CH3:输出电流") Case Else Exit Sub End Select If userInput <> "" Then ' 将输入的文字插入到表格中当前选中的单元格 selectedCell.Range.Text = userInput selectedCell.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter End If End Sub Sub Insert_even(x As Long) '波形图为偶数，使用该段 ' 获取当前光标所在位置 Dim select_cell As Cells Dim userInput As String Selection.InsertRowsBelow Set select_cell = Selection.Cells select_cell.Merge ' 弹出输入框 Select Case x Case 1 '单机模式 userInput = InputBox("请输入要插入的文字", "波形图标题", "CH1:输出电压 CH2:电感电流") Case 2 '市电模式 userInput = InputBox("请输入要插入的文字", "波形图标题", "CH1:输出电压 CH2:市电电流") Case 3 userInput = InputBox("请输入要插入的文字", "波形图标题", "CH1:反峰电压") Case 4 userInput = InputBox("请输入要插入的文字", "波形图标题", "CH1:Q1驱动电压 CH2:Q1驱动电压 CH3:输出电流") Case Else Exit Sub End Select If userInput <> "" Then ' 将输入的文字插入到表格中当前选中的单元格 select_cell.Item(1).Range.Text = userInput select_cell.Item(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter End If End Sub Private Sub UserForm_Click() End Sub 

模块调用

Sub ShowCustomDialog() ' 创建 UserForm 实例 Dim CustomDialog As UserForm1 ' 初始化 UserForm Set CustomDialog = New UserForm1 CustomDialog.Show End Sub 

 2023.8.7

Sub 测试() Dim selectedCells As Cells Dim cell As cell Dim cellText As String Dim dataArray() As Variant Dim i As Long Dim tmp As Long Dim num_count As Long ' 获取选中的单元格 Set selectedCells = Selection.Cells tmp = 0 num_count = 0 i = 1 If selectedCells Is Nothing Then MsgBox "未选中单元格" Exit Sub End If ' 遍历选中的单元格 For Each cell In selectedCells ' 计算单元格数量 num_count = num_count + 1 Next cell ' MsgBox num_count ' 设置数组长度 ReDim dataArray(1 To num_count) ' 遍历选中的单元格 For Each cell In selectedCells ' 存取单元格内容 Set CellRange = cell.Range CellRange.End = CellRange.End - 1 cellText = Trim(CellRange.Text) tmp = Val(cellText) dataArray(i) = tmp ' MsgBox i i = i + 1 Next cell ' MsgBox num_count ' MsgBox dataArray(2) ' 升序排列数组 SortArrayAscending dataArray ' 弹出消息框显示排序后的数组内容 ' MsgBox Join(dataArray, ", ") Dim creat_rows As Long ' 创建单元格 creat_rows = AddRowToSelectedTable(num_count) ' MsgBox creat_rows '调节单元格比例 AdjustColumn_width creat_rows, dataArray End Sub Sub SortArrayAscending(ByRef arr() As Variant) Dim i As Long Dim j As Long Dim temp As Variant For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(i) > arr(j) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub Function AddRowToSelectedTable(cell_count As Long) As Long Dim selectedTable As Cells Dim selectedCell As cell Dim lastRow As Object Dim cellToMerge As Cells Dim newCells As Range Dim select_Cell As Cells Dim row As Long ' MsgBox Selection.Type ' 检查是否有选中的单元格 If Selection.Type = 4 Then ' 获取选中的单元格对象 Set selectedCell = Selection.Cells(1) ' 获取选中单元格所在的表格对象 Set selectedTable = selectedCell.Tables.Parent.Column.Cells ' 存储选中表格的行数 Dim i As Long i = selectedTable.Count ' MsgBox "选中表格的行数：" & i ' 获取表格的最后一行 Set lastRow = selectedTable(i) ' 在表格的最后一行添加一行 lastRow.Select Selection.InsertRowsBelow Set select_Cell = Selection.Cells select_Cell.Merge ' 设置新行的列数为4 ' With Selection.Tables(1) ' .Columns.Add ' .Columns.Add ' .Columns.Add ' End With ' 计算生成几行，通过判断单元格个数是奇数或者偶数 Dim count_rows As Long count_rows = cell_count \ 2 ' 拆分单元格 If count_rows > 15 Then select_Cell.Split NumRows:=15, NumColumns:=4 select_Cell.Split NumRows:=count_rows - 15 + 1, NumColumns:=4 ElseIf count_rows <= 15 Then If cell_count Mod 2 = 0 Then select_Cell.Split NumRows:=count_rows, NumColumns:=4 Else count_rows = count_rows + 1 select_Cell.Split NumRows:=count_rows, NumColumns:=4 ' 提示添加成功 End If End If MsgBox "行已成功添加到选中的表格的最后一行，并且包含" & count_rows & "列。" Else ' 如果没有选中单元格，则提示错误 MsgBox "请先选中一个单元格。" End If ' 返回新建单元格的行数，用来单元格调整 AddRowToSelectedTable = count_rows End Function ' 新增用于对多行进行操作，调节列宽 Sub AdjustColumn_width(creat_rows As Long, arr() As Variant) 'creat_rows 为新建行数 Dim k As Long ' 用于确定数组坐标 Dim arr_index As Long arr_index = 1 For k = 1 To creat_rows arr_index = SelectRowOfSelectedCell(arr, arr_index) If Not k = creat_rows Then Selection.Cells(1).Next.Select End If Next k End Sub '分段 ' 调整表格列宽，并在但单元格中填入数据 Function SelectRowOfSelectedCell(arr() As Variant, arr_index As Long) As Long Dim SelectionRow As Object Dim selectedCells As Cells Dim c As cell Dim index As Long Dim percent As Single Set SelectionRow = Selection.Rows(1) SelectionRow.Select Set selectedCells = Selection.Cells index = selectedCells.Count For Each c In selectedCells ' c.Range.Text = arr() ' 当列表为1，2列，存arr(i) 3.4列存arr(i+1) If c.ColumnIndex = 1 Or c.ColumnIndex = 2 Then c.Range.Text = arr(arr_index) ElseIf c.ColumnIndex = 3 Or c.ColumnIndex = 4 Then If Not arr_index = UBound(arr) Then ' 检查索引是否超出数组的上界 c.Range.Text = arr(arr_index + 1) End If End If ' MsgBox c.PreferredWidthType ' 设置列宽形式为百分比 c.PreferredWidthType = wdPreferredWidthPercent If c.ColumnIndex = 1 Or c.ColumnIndex = index Then percent = 0.08 SetCellWidth percent, c Else percent = 0.42 SetCellWidth percent, c ' MsgBox c.PreferredWidthType ' MsgBox c.PreferredWidth End If Next c SelectRowOfSelectedCell = arr_index + 2 End Function ' 设置行列比例 Function SetCellWidth(percent As Single, c As cell) As Variant ' Dim tbl As Table Dim total_long As Double ' Set tbl = Selection.Tables(1) ' 假设选中的是表格中的单元格 ' 获取第2行第4列的单元格 ' Dim cell As cell ' Set cell = tbl.Range.Cells(Now_index) ' 取消选中"指定宽度"复选框 c.Select Selection.Cells(1).Select ' Selection.Cells(1).PreferredWidthType = wdPreferredWidthAuto total_long = CalculateTotalWidth ' MsgBox "总长" & total_long ' 设置单元格的宽度为5厘米 Selection.Cells(1).Width = total_long * percent Exit Function End Function '计算表格第一列长度 Function CalculateTotalWidth() As Double Dim totalWidth As Double Dim tbl As Table ' 假设tbl是您要操作的表格对象 Set tbl = ActiveDocument.Tables(5) totalWidth = 0 Dim firstRow As row Set firstRow = tbl.Rows(1) Dim firstCell As cell For Each firstCell In firstRow.Cells totalWidth = totalWidth + firstCell.Width Next firstCell CalculateTotalWidth = totalWidth End Function 

第二版

 Sub 测试() TraverseSelectedCells End Sub Sub TraverseSelectedCells() Dim selectedCells As Cells Dim cell As cell Dim cellText As String Dim dataArray() As Variant Dim i As Long Dim tmp As Long Dim num_count As Long ' 获取选中的单元格 Set selectedCells = Selection.Cells tmp = 0 num_count = 0 i = 1 If selectedCells Is Nothing Then MsgBox "未选中单元格" Exit Sub End If ' 遍历选中的单元格 For Each cell In selectedCells ' 计算单元格数量 num_count = num_count + 1 Next cell ' MsgBox num_count ' 设置数组长度 ReDim dataArray(1 To num_count) ' 遍历选中的单元格 For Each cell In selectedCells ' 存取单元格内容 Set CellRange = cell.Range CellRange.End = CellRange.End - 1 cellText = Trim(CellRange.Text) tmp = Val(cellText) dataArray(i) = tmp ' MsgBox i i = i + 1 Next cell ' MsgBox num_count ' MsgBox dataArray(2) ' 升序排列数组 SortArrayAscending dataArray ' 弹出消息框显示排序后的数组内容 MsgBox Join(dataArray, ", ") Dim creat_rows As Long ' 创建单元格 creat_rows = AddRowToSelectedTable(num_count) MsgBox creat_rows '调节单元格比例 AdjustColumn_width creat_rows, dataArray End Sub Sub SortArrayAscending(ByRef arr() As Variant) Dim i As Long Dim j As Long Dim temp As Variant For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(i) > arr(j) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub Function AddRowToSelectedTable(cell_count As Long) As Long Dim selectedTable As Cells Dim selectedCell As cell Dim lastRow As Object Dim cellToMerge As Cells Dim newCells As Range Dim select_Cell As Cells Dim row As Long ' MsgBox Selection.Type ' 检查是否有选中的单元格 If Selection.Type = 4 Then ' 获取选中的单元格对象 Set selectedCell = Selection.Cells(1) ' 获取选中单元格所在的表格对象 Set selectedTable = selectedCell.Tables.Parent.Column.Cells ' 存储选中表格的行数 Dim i As Long i = selectedTable.Count ' MsgBox "选中表格的行数：" & i ' 获取表格的最后一行 Set lastRow = selectedTable(i) ' 在表格的最后一行添加一行 lastRow.Select Selection.InsertRowsBelow Set select_Cell = Selection.Cells select_Cell.Merge ' 设置新行的列数为4 ' With Selection.Tables(1) ' .Columns.Add ' .Columns.Add ' .Columns.Add ' End With ' 计算生成几行，通过判断单元格个数是奇数或者偶数 Dim count_rows As Long count_rows = cell_count \ 2 ' 拆分单元格 If cell_count Mod 2 = 0 Then select_Cell.Split NumRows:=count_rows, NumColumns:=4 Else count_rows = count_rows + 1 select_Cell.Split NumRows:=count_rows, NumColumns:=4 ' 提示添加成功 End If MsgBox "行已成功添加到选中的表格的最后一行，并且包含" & count_rows & "列。" Else ' 如果没有选中单元格，则提示错误 MsgBox "请先选中一个单元格。" End If ' 返回新建单元格的行数，用来单元格调整 AddRowToSelectedTable = count_rows End Function ' 新增用于对多行进行操作，调节列宽 Sub AdjustColumn_width(creat_rows As Long, arr() As Variant) 'creat_rows 为新建行数 Dim k As Long ' 用于确定数组坐标 Dim arr_index As Long arr_index = 1 For k = 1 To creat_rows arr_index = SelectRowOfSelectedCell(arr, arr_index) If Not k = creat_rows Then Selection.Cells(1).Next.Select End If Next k End Sub '分段 ' 调整表格列宽，并在但单元格中填入数据 Function SelectRowOfSelectedCell(arr() As Variant, arr_index As Long) As Long Dim SelectionRow As Object Dim selectedCells As Cells Dim c As cell Dim index As Long Dim percent As Single Set SelectionRow = Selection.Rows(1) SelectionRow.Select Set selectedCells = Selection.Cells index = selectedCells.Count For Each c In selectedCells ' c.Range.Text = arr() ' 当列表为1，2列，存arr(i) 3.4列存arr(i+1) If c.ColumnIndex = 1 Or c.ColumnIndex = 2 Then c.Range.Text = arr(arr_index) ElseIf c.ColumnIndex = 3 Or c.ColumnIndex = 4 Then If Not arr_index = UBound(arr) Then ' 检查索引是否超出数组的上界 c.Range.Text = arr(arr_index + 1) End If End If ' MsgBox c.PreferredWidthType ' 设置列宽形式为百分比 c.PreferredWidthType = wdPreferredWidthPercent If c.ColumnIndex = 1 Or c.ColumnIndex = index Then percent = 0.08 SetCellWidth percent, c Else percent = 0.42 SetCellWidth percent, c ' MsgBox c.PreferredWidthType ' MsgBox c.PreferredWidth End If Next c SelectRowOfSelectedCell = arr_index + 2 End Function ' 设置行列比例 Function SetCellWidth(percent As Single, c As cell) As Variant ' Dim tbl As Table Dim total_long As Double ' Set tbl = Selection.Tables(1) ' 假设选中的是表格中的单元格 ' 获取第2行第4列的单元格 ' Dim cell As cell ' Set cell = tbl.Range.Cells(Now_index) ' 取消选中"指定宽度"复选框 c.Select Selection.Cells(1).Select ' Selection.Cells(1).PreferredWidthType = wdPreferredWidthAuto total_long = CalculateTotalWidth MsgBox "总长" & total_long ' 设置单元格的宽度为5厘米 Selection.Cells(1).Width = total_long * percent Exit Function End Function '计算表格第一列长度 Function CalculateTotalWidth() As Double Dim totalWidth As Double Dim tbl As Table ' 假设tbl是您要操作的表格对象 Set tbl = ActiveDocument.Tables(1) totalWidth = 0 Dim firstRow As row Set firstRow = tbl.Rows(1) Dim firstCell As cell For Each firstCell In firstRow.Cells totalWidth = totalWidth + firstCell.Width Next firstCell CalculateTotalWidth = totalWidth End Function