单元格的多个用分号隔开的字符串两两配对生成在新的单元格中

cuiyuanyuan1314

将b列单元格内的字符串两两配对，生成 GH列效果，其中G列保留相应的“专利代码”，H列两两配对的结果用分号间隔。麻烦各位大神啦！

jiangtaowoo

最近在学习嵌套映射，这个问题是比较典型的嵌套映射问题，问题的解可以通过两层映射得到：
1、A;B;C;D 这种数据实际是将 4 (数据长度) 映射为 [ (1,2),(1,3),(2,3),(1,4),(2,4),(3,4) ] 这样的不同数对组合序列，通过组合作为下标可以取得不同作者组合
2、对于每一行数据，实际上是将序列1234映射为 [ (专利编号,专利作者组合), ... ] 这样的序列，这就是结果序列了


思路比较简单，不过VBA不支持将函数作为参数传递给另一个高阶函数，所以代码写出来还是显得很复杂，比单纯用for循环结合求全组合应该复杂不少，不过思路结构比较简单，主体逻辑只需要少数几行代码。供参考。

cuiyuanyuan1314

感谢回复！ 我在运行中遇到一些问题，图片“问题1”和“问题2”反映了我的操作过程，最后代码没有运行成功，我想问一下这个代码我该怎么使用？具体可以在附件 “test2”上进行操作！再次感谢！

lsdongjh

1. Option Explicit
   
2. 
   
3. Dim arrResult As Variant
   
4. 
   
5. Sub Test()
   
6.     Dim arrSource As Variant
   
7.     Dim lngRows As Long, lngRow As Long
   
8.     Dim lngCount As Long
   
9.     Dim strID As String, strOriginator As String
   
10.    
    
11.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    
12.     arrSource = Sheet1.Range("A2:B" & lngRows)
    
13.    
    
14.     ReDim arrResult(1 To 2, 1 To 1)
    
15.     arrResult(1, 1) = "专利代码"
    
16.     arrResult(2, 1) = "发明人"
    
17.     lngCount = 1
    
18.    
    
19.     For lngRow = 1 To lngRows - 1
    
20.         strID = arrSource(lngRow, 1)
    
21.         strOriginator = arrSource(lngRow, 2)
    
22.         myPair strID, strOriginator, lngCount, arrResult
    
23.     Next
    
24.    
    
25.     arrResult = Application.WorksheetFunction.Transpose(arrResult)
    
26.     Sheet1.Range("F1").Resize(UBound(arrResult), 2) = arrResult
    
27. End Sub
    
28. 
    
29. 
    
30. Function myPair(strID As String, strVal As String, ByRef lngCount As Long, ByRef arrResult As Variant) As Boolean
    
31.     Dim strTemp() As String
    
32.     Dim intR1 As Integer, intR2 As Integer
    
33.     Dim intCount As Integer, intID As Integer
    
34.    
    
35.     strTemp = Split(strVal, ";")
    
36.     intCount = UBound(strTemp)
    
37.    
    
38.     If intCount = 0 Then
    
39.         myPair = False
    
40.         Exit Function
    
41.     End If
    
42.    
    
43.     For intR1 = 0 To intCount - 1
    
44.         For intR2 = intR1 + 1 To intCount
    
45.             lngCount = lngCount + 1
    
46.             ReDim Preserve arrResult(1 To 2, 1 To lngCount)
    
47.             arrResult(1, lngCount) = strID
    
48.             arrResult(2, lngCount) = strTemp(intR1) & ";" & strTemp(intR2)
    
49.          Next
    
50.     Next
    
51.    
    
52. End Function
    

复制代码

cuiyuanyuan1314

完美！ 非常感谢！！

cuiyuanyuan1314

lsdongjh 发表于 2018-6-8 11:46

大神，有还有一个问题想请教一下！烦请有时间的话指点一下！http://club.excelhome.net/thread-1418569-1-1.html

jiangtaowoo

cuiyuanyuan1314 发表于 2018-6-8 10:27
感谢回复！ 我在运行中遇到一些问题，图片“问题1”和“问题2”反映了我的操作过程，最后代码没有运行成功 ...

运行宏  Main 即可
如果要拷贝代码，把HyperFuncSet模块和Module1模块都拷贝过去，不要改动代码

hopeson2010

1. Sub ek_sky()
   
2.     Dim arr As Variant, brr() As Variant
   
3.     Dim i As Integer
   
4.        arr = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
   
5.           For i = 1 To UBound(arr)
   
6.              t = Split(arr(i, 2), ";")
   
7.              For j = 0 To UBound(t) - 1
   
8.                   For k = j + 1 To UBound(t)
   
9.                      L = L + 1
   
10.                      ReDim Preserve brr(1 To 2, 1 To L)
    
11.                      brr(1, L) = arr(i, 1)
    
12.                      brr(2, L) = t(j) & ";" & t(k)
    
13.                   Next k
    
14.              Next j
    
15.           Next i
    
16. Range("G:H").ClearContents
    
17. Range("G1:H1") = Array("专利代码", "发明人")
    
18. Range("G2").Resize(UBound(brr, 2), 2) = Application.WorksheetFunction.Transpose(brr)
    
19. End Sub
    

复制代码

小饼干910326

希望对你有帮助

cuiyuanyuan1314

谢谢大家！问题顺利解决！