VBA 大量多对多( 行与行的遍历配对 ), 链接 及 做相关统计

On_fire

VBA 大量多对多( 行与行的遍历配对 ), 链接 及 做相关统计

*

Sheet1是源数据, 每一行的单元格 ( 左到右 ) 是一组数据

Sheet2是关键词, 每一行的单元格 ( 左到右 ) 也是一组数据

*

代码需要建立,

建立一个临时表, 存放长链接, 因一行列数可能超EXCEL上限16384列,

可能需要在下一行输出, 比如在Q列开始往右填充...

*

代码的逻辑如下,

1.      Sheet2, 上到下, 左到右, 顺序提取关键词, 及顺序配对源数据( Sheet1每行的单元格)

2.      当配对上相同/重复的关键词, copy及将这一行的数据, 拉到同一行的右侧, 成一条长键接 ( 模拟在Sheet2(2) )

3.      找出长链接的重复关键词 ( 标黄 ), 及其它相同数据 ( 标绿 ), ( 模拟在Sheet2(3) )

4.      Sheet3是最终实现的统计及模拟结果

*

模拟在Sheet2(2) 及 Sheet2(3)是临时表的思路, 不知道可否优化?

*

难度大,

恳请大神, 老师出手帮忙...谢谢!

On_fire

早上好,
推一推…

ykcbf1100

你怎么都是出难题啊，搞研究工作的？

gwjkkkkk

有些难度，标记一下、、。

On_fire

ykcbf1100 发表于 2023-3-7 10:05
你怎么都是出难题啊，搞研究工作的？

EH论坛上, 有一些高难度的题目, 挺好的…百花齐放!

On_fire

gwjkkkkk 发表于 2023-3-7 10:28
有些难度，标记一下、、。

谢谢老师关注…

On_fire

On_fire 发表于 2023-3-7 08:31
早上好,
推一推…

早上好,
大家好,
再推一推…

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     Set d2 = CreateObject("scripting.dictionary")
   
8.     Set d3 = CreateObject("scripting.dictionary")
   
9.     With Worksheets("sheet2")
   
10.         brr = .Range("a1").CurrentRegion
    
11.         .Range("l1").Resize(.Rows.Count, .Columns.Count - 11).ClearContents
    
12.     End With
    
13.     With Worksheets("sheet1")
    
14.         r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
15.         c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
    
16.         arr = .Range("a1").Resize(r, c)
    
17.     End With
    
18.     For i = 1 To UBound(brr)
    
19.         d1.RemoveAll
    
20.         d2.RemoveAll
    
21.         d3.RemoveAll
    
22.         
    
23.         For j = 1 To UBound(brr, 2)
    
24.             If Len(brr(i, j)) <> 0 Then
    
25.                 d1(brr(i, j)) = Empty
    
26.             End If
    
27.         Next
    
28.         For k = 1 To UBound(arr)
    
29.             For j = 1 To UBound(arr, 2)
    
30.                 If Len(arr(k, j)) <> 0 Then
    
31.                     If d1.exists(arr(k, j)) Then
    
32.                         Exit For
    
33.                     End If
    
34.                 End If
    
35.             Next
    
36.             If j <= UBound(arr, 2) Then
    
37.                 For j = 1 To UBound(arr, 2)
    
38.                     If Len(arr(k, j)) <> 0 Then
    
39.                         If d1.exists(arr(k, j)) Then
    
40.                             d2(arr(k, j)) = d2(arr(k, j)) + 1
    
41.                         Else
    
42.                             d3(arr(k, j)) = d3(arr(k, j)) + 1
    
43.                         End If
    
44.                     End If
    
45.                 Next
    
46.             End If
    
47.         Next
    
48.         With Worksheets("sheet2")
    
49.             If d2.Count > 0 Then
    
50.                 ReDim crr(1 To d2.Count)
    
51.                 n = 0
    
52.                 For Each aa In d2.keys
    
53.                     n = n + 1
    
54.                     crr(n) = aa & "(" & d2(aa) & ")"
    
55.                 Next
    
56.                 With .Cells(i, 12).Resize(1, UBound(crr))
    
57.                     .Value = crr
    
58.                     .Interior.ColorIndex = 6
    
59.                 End With
    
60.             End If
    
61.             If d3.Count > 0 Then
    
62.                 ReDim drr(1 To d3.Count)
    
63.                 ReDim frr(1 To d3.Count)
    
64.                 x = 0
    
65.                 y = 0
    
66.                 For Each aa In d3.keys
    
67.                     If d3(aa) > 1 Then
    
68.                         x = x + 1
    
69.                         drr(x) = aa & "(" & d3(aa) & ")"
    
70.                     Else
    
71.                         y = y + 1
    
72.                         frr(y) = aa
    
73.                     End If
    
74.                 Next
    
75.                 With .Cells(i, 15).Resize(1, x)
    
76.                     .Value = drr
    
77.                     .Interior.ColorIndex = 4
    
78.                 End With
    
79.                 .Cells(i, 17).Resize(1, y) = frr
    
80.             End If
    
81.         End With
    
82.     Next
    
83.                
    
84. End Sub
    

复制代码

chxw68

这个还是有点绕的。

On_fire

chxw68 发表于 2023-3-8 11:11
这个还是有点绕的。

褚老师,
感谢您能出手帮忙…真好!