（请教高手！）单元格内的多个用分号隔开的字符串用另一个表格对应的数值代替

长春鱼鱼

有2个表格（如下，更多数据见附件）:
表格1，A列单元格内,每个数值被分号;隔开。
1）如果数值带有#，则数值用#后面的字符替换（如193#Black 用 Black 替换）；如果#后的英文字符有重复的，则在字符后面加上1、2、3..以示区别（见例子A6）。

2）如果数值没有#，只有数字，则数值用表2中数字对应的“属性值"替换。（如771 用 Beige 替换）

替换后的结果，放到B列，且每个数值用逗号隔开。

表1 ：

Color  Name	替换后结果
193#Black;10#Burgundy;175#Green	Black,Burgundy,Green
173;175;10#Rhodo;366	Blue,Green,Rhodo,Yellow
771;173	Beige,Blue
771#beige;1052#pink	Beige,Pink
771#multicolor;173#multicolor;1254#multicolor	Multicolor1,Multicolor2,Multicolor3

表2：

属性组	属性	属性值
蓝	173	Blue
绿	175	Green
黄	366	Yellow
米色	771	Beige
蓝	173	Blue
红	10	Red

山菊花

请测试。

长春鱼鱼

山菊花 发表于 2015-7-14 18:14
请测试。

是不是传错附件了阿，大哥？附件中代码或公式都没有啊？

山菊花

已更新附件，麻烦再下载。

doitbest

Public Sub abc()
Dim ar, rep, i, ii, str, tmp, d
Set d = CreateObject("Scripting.Dictionary")
ar = Range([a2], [a65536].End(3))
Set rep = CreateObject("vbscript.regexp")
rep.Global = True
For i = 1 To UBound(ar)
    rep.Pattern = "\d+#"
    If ar(i, 1) <> "" Then
      ar(i, 1) = rep.Replace(ar(i, 1), "")
      ar(i, 1) = Replace(ar(i, 1), " ", ";")
      str = Split(ar(i, 1), ";")
      For ii = 0 To UBound(str)
        str(ii) = StrConv(str(ii), 3)
        If IsNumeric(str(ii)) And Not Sheet2.[b:b].Find(str(ii), , , 1) Is Nothing Then
            str(ii) = Sheet2.[b:b].Find(str(ii), , , 1).Offset(, 1)
        End If
        d(str(ii)) = d(str(ii)) + 1
      Next
      For ii = 0 To UBound(str)
          If d(str(ii)) > 1 Then
             d(str(ii) & "@") = d(str(ii) & "@") + 1
              tmp = tmp & " " & str(ii) & d(str(ii) & "@")
          Else
              tmp = tmp & " " & str(ii)
          End If
      Next
      ar(i, 1) = Replace(Trim(tmp), " ", ",")
      tmp = ""
      d.RemoveAll
    End If
Next
[b2].Resize(UBound(ar)) = ar
End Sub

长春鱼鱼

山菊花 发表于 2015-7-14 18:14
请测试。

真是太太太........强大呢！！测试后，100%解决问题。

能否帮忙看另一个帖子。它跟这个帖子问题90%类似，可能要在这个函数基础上修改下就好。我目前功底完全不行阿。多谢！
http://club.excelhome.net/thread-1217256-1-1.html

doitbest

请参考附件

长春鱼鱼

doitbest 发表于 2015-7-14 18:45
Public Sub abc()
Dim ar, rep, i, ii, str, tmp, d
Set d = CreateObject("Scripting.Dictionary")

代码有些错误，见附件测试结果。红色，就是代码返回的错误的值，左侧是正确的。

有些颜色名由2个单词构成，比如Light Blue。你的代码 Light Blue 分开了。

doitbest

长春鱼鱼 发表于 2015-7-14 19:19
代码有些错误，见附件测试结果。红色，就是代码返回的错误的值，左侧是正确的。

有些颜色名由2个单词 ...

略加修改即可
Public Sub abc()
Dim ar, rep, i, ii, str, tmp, d
Set d = CreateObject("Scripting.Dictionary")
ar = Range([a2], [a65536].End(3))
Set rep = CreateObject("vbscript.regexp")
rep.Global = True
For i = 1 To UBound(ar)
    rep.Pattern = "\d+#"
    If ar(i, 1) <> "" Then
      ar(i, 1) = rep.Replace(ar(i, 1), "")
      str = Split(ar(i, 1), ";")
      For ii = 0 To UBound(str)
        str(ii) = StrConv(str(ii), 3)
        If IsNumeric(str(ii)) And Not Sheet2.[b:b].Find(str(ii), , , 1) Is Nothing Then
            str(ii) = Sheet2.[b:b].Find(str(ii), , , 1).Offset(, 1)
        End If
        d(str(ii)) = d(str(ii)) + 1
      Next
      For ii = 0 To UBound(str)
          If d(str(ii)) > 1 Then
             d(str(ii) & "@") = d(str(ii) & "@") + 1
              tmp = tmp & "," & str(ii) & d(str(ii) & "@")
          Else
              tmp = tmp & "," & str(ii)
          End If
      Next
      ar(i, 1) = Right(tmp, Len(tmp) - 1)
      tmp = ""
      d.RemoveAll
    End If
Next
[b2].Resize(UBound(ar)) = ar
End Sub

长春鱼鱼

doitbest 发表于 2015-7-14 19:24
略加修改即可
Public Sub abc()
Dim ar, rep, i, ii, str, tmp, d

还是有个小小问题。部分数值，没有按照首字母A-Z排列阿？

见附件，红色为返回的错误的值。
另外，能不能帮忙解答下下面这个新帖子阿。它的问题同当前帖子90%类似。万分感谢！
http://club.excelhome.net/thread-1217256-1-1.html