匹配数据的代码完善

VBA之恋

这个贴子是以前求助过的，但当时举例子时，我考虑不周全，所以提供帮助的老师没有考虑这个方面，实不好意思再向其求助，特开一贴求助。
此代码的功能是：有一表，见图：根据M列的关键字所对应的S列相对应的内容（存在一对多），来填充S列空白的单元格。数据量很大，有几十万行。S列中，原先有数据的，就无需匹配数据，那怕存在一对多情景，也不改变此单元格的内容，空白的，则匹配上所有对应的值。如M列关键字所对应的S列为全是空的，其结果也应为空的。
所匹配的结果，要去除重复项，前面不要有符号带头。
图中甲-0043到0049，S列应为空的
原代码在附件中。请运行后，即明白我所求助的意思

匹配资料精进求助 .rar (55.47 KB, 下载次数: 7)

2020-2-23 13:29 上传

点击文件名下载附件

gbgbxgb

把求助要求写的这么深奥，反反复复看了几遍，咀嚼了再咀嚼，总感觉你的描述还是让人云里雾里，你的语言功底太差了。试着帮你描述下：
1.若S列已有内容的，不要动它；
2.填充S列的空白单元格；
3.具体填充时，考虑S列对应行的M列内容（后文称关键字），若在此行前该关键字曾有过S列内容，则填充该关键字对应过的S列内容（注：该关键字对应过的S列内容呈现为叠加状态，比如：最早时为“张××”，再后来为“张××、李××”，其中用顿号分隔，当然了，叠加时，张××、李××均不用重复，即不用呈现为“张××、张××、李××、李××”）。
4.（你要是真写了这一点，那显然是废话）若关键字均不曾对应有S列的有效内容，那么S列显然仍是空白。

事后补：
发现“VBA之恋”这昵称老脸熟了，你何以混迹Excel论坛这许年之久，这样的简单逻辑加简单VBA代码还搞不定，仍然做伸手党耶？

gbgbxgb

参考下列代码（注：结果填充在了T列）：

1. Sub kkk()
   
2.     Dim d As Object, theStr1$, theStr2$, theItemStr$
   
3.     Dim theFinalRow&, i&, arr As Variant, brr As Variant
   
4.     '
   
5.     Set d = CreateObject("SCripting.Dictionary")
   
6.     With Sheet7
   
7.         theFinalRow = .Cells(.Rows.Count, 13).End(xlUp).Row
   
8.         If theFinalRow < 2 Then GoTo The_Exit
   
9.         arr = .Range(.Cells(2, 13), .Cells(theFinalRow, 13))
   
10.         brr = .Range(.Cells(2, 19), .Cells(theFinalRow, 19))
    
11.         If Not IsArray(arr) Then
    
12.             ReDim arr(1 To 1, 1 To 1)
    
13.             ReDim brr(1 To 1, 1 To 1)
    
14.             arr(1, 1) = .Cells(2, 13)
    
15.             brr(1, 1) = .Cells(2, 19)
    
16.         End If
    
17.         '
    
18.         For i = 1 To UBound(arr)
    
19.             theStr1 = brr(i, 1) 'S列内容
    
20.             theStr2 = arr(i, 1) '关键字
    
21.             If theStr1 = "" Then
    
22.                 If d.exists(theStr2) Then brr(i, 1) = d(theStr2)
    
23.             Else
    
24.                 If d.exists(theStr2) Then
    
25.                     theItemStr = "、" & d(theStr2) & "、"
    
26.                     If InStr(1, theItemStr, theStr1) = 0 Then
    
27.                         d(theStr2) = d(theStr2) & "、" & theStr1
    
28.                     End If
    
29.                 Else
    
30.                     d(theStr2) = theStr1
    
31.                 End If
    
32.             End If
    
33.         Next i
    
34.         .Cells(2, 20).Resize(UBound(brr)) = brr
    
35.     End With
    
36. The_Exit:
    
37.     Set d = Nothing
    
38. End Sub

复制代码

VBA之恋

gbgbxgb 发表于 2020-2-23 14:35
把求助要求写的这么深奥，反反复复看了几遍，咀嚼了再咀嚼，总感觉你的描述还是让人云里雾里，你的语言功底 ...

呵，谢了谢了。学过一段时间，觉得好难呀