在A列相同数据对应的B列数据中进行排列组合，求指导

nbmitxihc

如下图，E列重复A列数据， 在A列相同数据对应的B列数据中进行排列组合，数据生成到FG列中，感谢大侠有指导和帮助

谢谢.rar (9.04 KB, 下载次数: 9)

2018-10-10 09:07 上传

点击文件名下载附件

编号__9527

1. Sub 排列()
   
2.     Dim lr1%, lr2%, n%
   
3.     n = 2
   
4.     lr1 = Cells(Rows.Count, 1).End(3).Row
   
5.     lr2 = Cells(Rows.Count, 2).End(3).Row
   
6.     arr = Range("a2:a" & lr1)
   
7.     brr = Range("b2:b" & lr2)
   
8.     Range("e:g").ClearContents
   
9.     For i = 1 To UBound(arr)
   
10.        If Application.CountIf(Range("a2:a" & lr1), arr(i, 1)) = 1 Then
    
11.            Cells(n, 5) = arr(i, 1)
    
12.             Cells(n, 6) = brr(i, 1)
    
13.              Cells(n, 7) = ""
    
14.              n = n + 1
    
15.            End If
    
16.       
    
17.         If Application.CountIf(Range("a2:a" & lr1), arr(i, 1)) <> 1 Then
    
18.                For j = 1 To UBound(brr)
    
19.          
    
20.                If arr(i, 1) = arr(j, 1) And i <> j Then
    
21.                 Cells(n, 5) = arr(i, 1)
    
22.                 Cells(n, 6) = brr(i, 1)
    
23.                 Cells(n, 7) = brr(j, 1)
    
24.                 n = n + 1
    
25.               
    
26.               End If
    
27. '        Else
    
28. '            Cells(n, 5) = arr(i, 1)
    
29. '            Cells(n, 6) = brr(i, 1)
    
30. '             Cells(n, 7) = ""
    
31. '             n = n + 1
    
32.             Next j
    
33.         End If
    
34.             
    
35.         
    
36.     Next i
    
37. End Sub
    

复制代码

ykqrs

1. Option Explicit
   
2. Dim s, brr(), m%, k%, aa
   
3. Sub 排列()
   
4. Dim d, r%, arr, i%, x%
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Columns("i:k") = ""
   
7. r = Cells(Rows.Count, 1).End(xlUp).Row
   
8. arr = Range("a2:b" & r)
   
9. For i = 1 To UBound(arr)
   
10. d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
    
11. Next
    
12. For Each aa In d.keys
    
13. s = Split(d(aa), ",")
    
14. m = UBound(s)
    
15. If m > 1 Then
    
16. x = Application.Permut(m, 2)
    
17. ReDim brr(1 To x, 1 To 3): k = 0
    
18. Call digui("", "", 0)
    
19. r = Cells(Rows.Count, "i").End(xlUp).Row
    
20. Cells(r + 1, "i").Resize(k, 3) = brr: Erase brr
    
21. Else
    
22. r = Cells(Rows.Count, "i").End(xlUp).Row
    
23. Cells(r + 1, "i") = aa: Cells(r + 1, "j") = s(1)
    
24. End If
    
25. Next
    
26. End Sub
    
27. Sub digui(s1$, s2$, t%)
    
28. Dim i%
    
29. If t = 2 Then
    
30. k = k + 1: brr(k, 1) = aa: brr(k, 2) = Split(s1, "|")(1): brr(k, 3) = Split(s1, "|")(2)
    
31. Else
    
32. For i = 1 To m
    
33. If InStr(s2 & ",", "," & i & ",") = 0 Then
    
34. Call digui(s1 & "|" & s(i), s2 & "," & i, t + 1)
    
35. End If
    
36. Next
    
37. End If
    
38. End Sub
    

复制代码

ykqrs

谢谢.rar (11.7 KB, 下载次数: 2)

2018-10-11 10:52 上传

点击文件名下载附件

nbmitxihc

ykqrs 发表于 2018-10-11 10:52

非常感谢老师指导

nbmitxihc

编号__9527 发表于 2018-10-10 18:07

非常感谢老师指导，谢谢