全排列求助

1we123

要求：数据1的全排列数据与数据2的每一行数据的全排列数据对比，如果数据1某一全排列数据的第一二位之和等于数据2某一全排列数据的第一二位之和相等，且第三四位之和等于数据2某一全排列数据的第三四位之和相等，就将数据2标红！
例：[url=]全排列求助.zip[/url]

longwin

Sub test()
    With ActiveSheet()
        For i = 2 To .Cells(1, 11).End(xlDown).Row
            If .Cells(i, 11) + .Cells(i, 12) = .Cells(2, 3) + .Cells(2, 4) And .Cells(i, 13) + .Cells(i, 14) = .Cells(2, 5) + .Cells(2, 6) Then
                .Range(.Cells(i, 11), .Cells(i, 16)).Interior.Color = RGB(255, 0, 0)
            End If
        Next
    End With
End Sub

1we123

longwin 发表于 2024-4-25 12:57
Sub test()
    With ActiveSheet()
        For i = 2 To .Cells(1, 11).End(xlDown).Row

谢谢，可能我的要求没说清楚，是数据1的全排列720中的某个与数据2某行数据的全排列720个中的符合这种规律，就可以标红

ykcbf1100

没有满足条件的记录。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.25
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Cells.Interior.ColorIndex = 0
   
4.     arr = [c2:h2]
   
5.     s1 = arr(1, 1) + arr(1, 2)
   
6.     s2 = arr(1, 3) + arr(1, 4)
   
7.     s = s1 & "|" & s2
   
8.     d(s) = ""
   
9.     r = Cells(Rows.Count, "k").End(3).Row
   
10.     arr = Range("k1:p" & r)
    
11.     For i = 2 To UBound(arr)
    
12.         s1 = arr(i, 1) + arr(i, 2)
    
13.         s2 = arr(i, 3) + arr(i, 4)
    
14.         s = s1 & "|" & s2
    
15.         If d.exists(s) Then
    
16.             Cells(i, "k").Resize(1, 6).Interior.ColorIndex = 3
    
17.         End If
    
18.     Next
    
19.     MsgBox "OK！"
    
20. End Sub
    

复制代码

LIUZHU

JSA参与下，感觉满足条件的还挺多的

1. function test(){
   
2.         let karr=Range("c2:h2").Value2[0];
   
3.         carr=myplzh(karr,"排列",karr.length,karr.length);
   
4.         let arr=Range("k2:p393").Value2;
   
5.         arr.forEach((x,i)=>{
   
6.                 let temp=myplzh(x,"排列",x.length,x.length);
   
7.                 if (new Set(carr.concat(temp)).size<carr.length+temp.length){
   
8.                         Cells.Item(i+2,11).Resize(1,karr.length).Interior.Color=255;
   
9.                 }
   
10.                
    
11.         });
    
12. }
    
13. 
    
14. function myplzh(szarr,type,m,n){
    
15.         if (m<n) return;
    
16.         szarr=szarr.slice(0,m);
    
17.         let obj={},temp=new Array(n).fill(null);
    
18.         let h=0;                                        //h：统计递归所在的层数，不超过最底层(n-1)
    
19.         function getplzh(k){                //k：递归循环的起始位置
    
20.                 for (let i=k;i<m;i++){
    
21.                         if (temp.includes(szarr[i])) continue;                //统计不重复值
    
22.                         temp[h]=szarr[i];
    
23.                         if (temp[n-1]!=null) obj[`${temp[0]+temp[1]},${temp[2]+temp[3]}`]=null;
    
24.                         if (h<n-1){                                        //判断是否到达底层(n-1)，未达到则继续往下一层递归
    
25.                                 h++;                                        //层数递增
    
26.                                 getplzh(type=="组合"?i+1:0);                //递归,如果是组合，起始位置从i+1开始，否则从0开始
    
27.                         }
    
28.                 }
    
29.                 temp[h]=null;                //退出本层之前，将元素位置置空(null)
    
30.                 h--;                                //循环结束，退回到递归的上一层
    
31.         }
    
32.         getplzh(0);
    
33.         return Object.keys(obj);
    
34. }
    

复制代码

LIUZHU

附件请用WPS测试

LIUZHU

1we123 发表于 2024-4-25 13:24
谢谢，可能我的要求没说清楚，是数据1的全排列720中的某个与数据2某行数据的全排列720个中的符合这种规律 ...

1、把数据1的720种排列，第1位和第2位之和、第3位和第4位之和组合成一个字符，生成字典的键，假设叫数组A；
2、把数据2每一行的720种排列，第1位和第2位之和、第3位和第4位之和组合成一个字符，生成字典的键，假设叫数组B；
3、数组A和数组B合并去重，得到数组C；
如果数组C的元素个数，小于数组A和数组B的元素个数和，则表示数组2的那行数据是符合要求的。

longwin

Sub pl()
    arr = ThisWorkbook.Sheets("Sheet1").Range("C2:H2")
    arr2 = sz(arr)
   
    For p = 2 To ThisWorkbook.Sheets("Sheet1").Cells(1, 11).End(xlDown).Row
   
    brr = ThisWorkbook.Sheets("Sheet1").Range("K" & p & ":P" & p)
   
    brr2 = sz(brr)
   
    For i = 1 To 90
        For j = 1 To 90
            If arr2(i, 1) = brr2(j, 1) And arr2(i, 2) = brr2(j, 2) Then
                ThisWorkbook.Sheets("Sheet1").Range("K" & p & ":P" & p).Interior.Color = RGB(255, 0, 0)
                ThisWorkbook.Sheets("Sheet1").Range("Q" & p) = arr2(i, 3)
                ThisWorkbook.Sheets("Sheet1").Range("R" & p) = brr2(j, 3)
                Exit For
            End If
        Next
    Next
Next
   
    MsgBox "判断完毕！"
   
   
   
   
   
   
End Sub
Function sz(arr) As Variant
    Dim qzrr(1 To 90, 1 To 3)
    n = 1
    '6选2，剩余4中再选2
    For i = 1 To 5
        For j = i + 1 To 6
            ss = arr(1, i) & "|" & arr(1, j)
            qz1 = arr(1, i) + arr(1, j)
            
            '取剩余4个
            For k = 1 To 6
                If k <> i And k <> j Then
                    pp = pp & "|" & arr(1, k)
                End If
            Next
            
            brr = Split(pp, "|")
            
            '剩余4个里面选2个
            For p1 = 1 To 3
                For p2 = p1 + 1 To 4
                    ppp = brr(p1) & "|" & brr(p2)
                    
                    qz2 = CInt(brr(p1)) + CInt(brr(p2))
                    qzrr(n, 1) = qz1
                    qzrr(n, 2) = qz2
                    
                    qzrr(n, 3) = ss & "|" & ppp
                    
                    n = n + 1
                    pp = ""
                    ppp = ""
                    
                Next
            Next
        Next
    Next
    sz = qzrr
End Function

longwin