ExcelTip.Net留存知识帖 ---【注:附件之前被网盘供应商清空后,现已修复-现已修复-现已修复为本地下载!】
现在位置:首页 > E问E答 > Excel VBA > 如何将2列文字接龙并返回所有可能组合?

如何将2列文字接龙并返回所有可能组合?

作者:绿色风 分类: 时间:2022-08-17 浏览:161
楼主
liuguansky
Q:如何将2列文字接龙并返回所有可能组合?如下图,如果A列中的内容,后2个字与B列中的内容前2个字一致,则将其组合成为4个字并返回所有可能组合。如A列中有“丁七口”,B列中有“七口士”、“七口干”、“七口且”、“七口由”,则可以组合成“丁七口士”、“丁七口干”、“丁七口且”、“丁七口由”。

A:使用下面的代码:
  1. Sub justtest()
  2.     Dim d1, d2, arr
  3.     Dim i&, s1$, s2$, s3$, s4$, d, k&, arr1, arr2, j&, arrt()
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     Set d2 = CreateObject("scripting.dictionary")
  6.     arr = Cells(2, 1).Resize(Cells(1, 1).End(4).Row - 1, 2).Value
  7.     For i = 1 To UBound(arr, 1)
  8.         s1 = Right(arr(i, 1), 2): s2 = Left(arr(i, 1), 1)
  9.         s3 = Left(arr(i, 2), 2): s4 = Right(arr(i, 2), 1)
  10.         If arr(i, 1) <> "" Then
  11.             If d1.Exists(s1) Then
  12.                 d1(s1) = d1(s1) & "," & s2
  13.                 Else: d1.Add s1, s2
  14.             End If
  15.         End If
  16.         If arr(i, 2) <> "" Then
  17.             If d2.Exists(s3) Then
  18.                 d2(s3) = d2(s3) & "," & s4
  19.                 Else: d2.Add s3, s4
  20.             End If
  21.         End If
  22.     Next i
  23.     For Each d In d1.Keys
  24.         If d2.Exists(d) Then
  25.             arr1 = Split(d1(d), ",")
  26.             arr2 = Split(d2(d), ",")
  27.             For i = 0 To UBound(arr1)
  28.                 For j = 0 To UBound(arr2)
  29.                     k = k + 1: ReDim Preserve arrt(1 To 1, 1 To k)
  30.                     arrt(1, k) = arr1(i) & d & arr2(j)
  31.             Next j, i
  32.         End If
  33.     Next
  34.     Range("d2:d" & Rows.Count).Clear
  35.     Cells(2, 4).Resize(k, 1) = Application.Transpose(arrt)
  36.     Set d1 = Nothing: Set d2 = Nothing
  37. End Sub
2楼
eliane_lei
进来学习!谢谢分享!

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素, 经与ExcelTip.Net站长Apolloh商议并征得其同意, 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示, 供有需要的人士查询使用,也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议, 可与本人沟通提出,或于本站点留言,我们会尽快处理。 在此,感谢ExcelTip.Net站长Apolloh的支持,感谢本站点所有人**绿色风(QQ:79664738)**的支持与奉献,特此鸣谢!
------本人网名**KevinChengCW(QQ:1210618015)**原ExcelTip.Net总版主之一

评论列表
sitemap