重新排列的问题

风波亭

1.将C3:E5区域内的单元格，进行重新排列(按照位置)
2.例如C3:E3。里面的单元格数据是10M，对这三个数据进行排列，记过如L2:N7所示
3.结果放到L2:n13里面

ynzsvt

同一行三个会不会重复，要去重不

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, k&, r&
   
    Application.ScreenUpdating = False
   
    ar = Range("C3:E4").Value
    ReDim br(1 To WorksheetFunction.Permut(UBound(ar, 2), UBound(ar, 2)) * UBound(ar), 1 To UBound(ar, 2))
    For i = 1 To UBound(ar)
        cr = Application.Index(ar, i)
        bSort1 cr, 1, UBound(cr)
        cr = ArrPermut(cr, UBound(cr))
        For k = 1 To UBound(cr)
            r = r + 1
            For j = 1 To UBound(cr, 2)
                br(r, j) = cr(k, j)
            Next j
        Next k
    Next i
   
    [L2].Resize(UBound(br), UBound(br, 2)) = br
    Application.ScreenUpdating = True
    Beep
End Sub
Function ArrPermut(ar, n&)
    Dim br&(), cr&(), vResult, i&, j&, k&, m&, iGroup&
  
    m = UBound(ar)
    iGroup = WorksheetFunction.Permut(m, n)
    ReDim br(1 To n), cr(1 To m), vResult(1 To iGroup, 1 To n)
   
    For j = 1 To n
        br(j) = j: cr(j) = 1
        vResult(1, j) = ar(j)
    Next
    For i = 2 To iGroup
        For j = n To 1 Step -1
            cr(br(j)) = 0
            For k = br(j) + 1 To m
                If cr(k) = 0 Then Exit For
            Next
            If k <= m Then cr(k) = 1: br(j) = k: Exit For
        Next
        For j = j + 1 To n
            For k = 1 To m
                If cr(k) = 0 Then Exit For
            Next
            cr(k) = 1: br(j) = k
        Next
        For j = 1 To n
            vResult(i, j) = ar(br(j))
        Next
    Next
   
    ArrPermut = vResult
End Function
Function bSort1(ar, iFirst&, iLast&, _
    Optional isOrder As Boolean = True)
    Dim i&, j&, vTemp
   
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j) <> ar(j + 1) Then
                If ar(j) < ar(j + 1) Xor isOrder Then
                    vTemp = ar(j)
                    ar(j) = ar(j + 1)
                    ar(j + 1) = vTemp
                End If
            End If
        Next j
    Next i
End Function

ykcbf1100

附件供参考。。。

gwjkkkkk

请参考附件。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.6.10
   
2.     Dim brr(1 To 10000, 1 To 3)
   
3.     r = Cells(Rows.Count, 3).End(3).Row
   
4.     arr = [c3].Resize(r - 2, 3)
   
5.     On Error Resume Next
   
6.     For i = 1 To UBound(arr)
   
7.         For a = 1 To 3
   
8.             sa = arr(i, a)
   
9.             For b = 1 To 3
   
10.                 If sa <> arr(i, b) Then
    
11.                     sb = arr(i, b)
    
12.                     For c = 1 To 3
    
13.                         If arr(i, c) <> sb And arr(i, c) <> sa Then
    
14.                             sc = arr(i, c)
    
15.                             m = m + 1
    
16.                             brr(m, 1) = sa
    
17.                             brr(m, 2) = sb
    
18.                             brr(m, 3) = sc
    
19.                         End If
    
20.                     Next
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.     Next
    
25.     [l:n] = ""
    
26.     [l2].Resize(m, 3) = brr
    
27. End Sub
    
28. 
    

复制代码

风波亭

gwjkkkkk 发表于 2024-6-10 14:53
Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, k&, r&

老师不需要去重，反过来求解,程序又该怎么求解？附件如下：

风波亭

ykcbf1100 发表于 2024-6-10 14:55
参与一下。。。

谢谢老师，不需要重复的，现实中，重复的几率很低，现在想来，去掉重复似乎更好。。。。老师，反过来求解,程序又该怎么求解？

ykcbf1100

风波亭 发表于 2024-6-10 21:01
谢谢老师，反过来求解,程序又该怎么求解？

反向不好解。

gwjkkkkk

反过来求解什么意思