如何用vba随机排列word行数据

zzpsx

用vba随机排列行.zip (9.43 KB, 下载次数: 2)

2024-11-10 12:13 上传

点击文件名下载附件

lizhipei78

先把表格读取到数组，对数组进行随机排序，然后写回到表格中就好了，跟Excel一样的操作

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, i&, j&, m&, n&, Par As Paragraph, objTable As Table, Rng As Range
   
    Application.ScreenUpdating = False
   
    With ActiveDocument.Tables(1)
        m = .Rows.Count: n = .Columns.Count
        ReDim ar(1 To m, 1 To n)
        For i = 1 To UBound(ar)
            For j = 1 To UBound(ar, 2)
                ar(i, j) = Left(.Cell(i, j).Range.Text, Len(.Cell(i, j).Range.Text) - 2)
            Next j
        Next i
         arrGetRnd2 ar
        For i = 1 To UBound(ar)
            For j = 1 To UBound(ar, 2)
                 .Cell(i, j).Range.Text = ar(i, j)
            Next j
        Next i
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function arrGetRnd2(ByRef ar, Optional ByVal isCol As Boolean)
    Dim xNum&, i&, j&, m&, n&, y&, x&, vTemp
   
    Randomize
    m = UBound(ar): n = UBound(ar, 2)
   
    If isCol Then
        vTemp = m: m = n: n = vTemp
        y = LBound(ar, 2): x = LBound(ar)
    Else
        y = LBound(ar): x = LBound(ar, 2)
    End If
   
    For i = y To m - 1
        xNum = Int((m - i + 1) * Rnd() + i)
        For j = x To n
            If isCol Then
                vTemp = ar(j, xNum): ar(j, xNum) = ar(j, i): ar(j, i) = vTemp
            Else
                vTemp = ar(xNum, j): ar(xNum, j) = ar(i, j): ar(i, j) = vTemp
            End If
        Next
    Next
End Function

gwjkkkkk

请参考。。。

taller

1. Option Explicit
   
2. ' 借助Excel实现Word表格排序
   
3. Sub SortTab()
   
4.     Dim oTab As Table, aData, sTxt As String
   
5.     Set oTab = ActiveDocument.Tables(1)
   
6.     Dim oRow As Row, oCell As Cell, iR As Long, iC As Long
   
7.     ReDim aData(1 To oTab.Rows.Count, 1 To oTab.Columns.Count)
   
8.     Randomize
   
9.     For Each oRow In oTab.Rows
   
10.         iR = iR + 1: iC = 0
    
11.         For Each oCell In oRow.Cells
    
12.             iC = iC + 1
    
13.             If iC = 1 Then
    
14.                 aData(iR, iC) = Rnd() * 10000
    
15.             Else
    
16.             sTxt  = oCell.Range.Text
    
17.             aData(iR, iC) = Left(sTxt , Len(sTxt ) - 1)
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     Dim xlApp, xlWK, xlSht
    
22.     Set xlApp = CreateObject("excel.application")
    
23.     'Set xlApp = GetObject(, "excel.application")
    
24.     Set xlWK = xlApp.workbooks.Add
    
25.     Set xlSht = xlApp.activesheet
    
26.     With xlSht.Range("A1")
    
27.         .Resize(UBound(aData), UBound(aData, 2)).Value = aData
    
28.         .currentregion.Sort key1:=.Cells(1), header:=0
    
29.         aData = .currentregion.Value
    
30.     End With
    
31.     xlWK.Close False
    
32.     xlApp.Quit
    
33.     Set xlApp = Nothing
    
34.     iR = 0
    
35.     For Each oRow In oTab.Rows
    
36.         iR = iR + 1: iC = 0
    
37.         For Each oCell In oRow.Cells
    
38.             iC = iC + 1
    
39.             If iC > 1 Then
    
40.                 oCell.Range.Text = Left(aData(iR, iC), Len(aData(iR, iC)) - 1)
    
41.             End If
    
42.         Next
    
43.     Next
    
44. End Sub
    

复制代码