WPS VBA 最新版本

 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