请问如何将一列中非空白的单元格内容提取到另一个单元格，并以逗号分隔?

wayne2705

也就是将品名栏中不重叠的名称提取到E2单元格，并以逗号分隔。我不知道如何排除重叠的名称，要用VBA编写。

cjc209

字典就去重 最后再jion就行了

全党

1. <div class="blockcode"><blockquote>Sub d()
   
2. Set dic = CreateObject("Scripting.Dictionary")
   
3. arr = [a1].CurrentRegion
   
4. For i = 2 To UBound(arr)
   
5.   If arr(i, 1) <> "" Then
   
6.   dic(arr(i, 1)) = ""
   
7.   End If
   
8. Next
   
9. [e2] = VBA.Join(dic.keys, ",")
   
10. End Sub

复制代码

Jaofuan

1. Sub jaofuan()
   
2.     Dim d As Object, ar, row As Long, x As String
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     row = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
   
5.     ar = ActiveSheet.Range("A1:A" & row)
   
6.     For i = 1 To UBound(ar)
   
7.         If Not d.exists(ar(i, 1)) Then
   
8.             d(ar(i, 1)) = ""
   
9.             If x = "" Then
   
10.                 x = ar(i, 1)
    
11.             Else
    
12.                 x = x & "，" & ar(i, 1)
    
13.             End If
    
14.         End If
    
15.     Next
    
16.     ActiveSheet.Range("E2") = x
    
17. End Sub
    

复制代码

全党

也可以这样
Sub d()
Set dic = CreateObject("Scripting.Dictionary")
arr = [a1].CurrentRegion
dic(arr(2, 1)) = arr(2, 1)
For i = 3 To UBound(arr)
  If arr(i, 1) <> "" Then
    If Not dic.exists(arr(i, 1)) Then
  dic(arr(i, 1)) = dic(arr(i - 1, 1)) & "," & arr(i, 1)
  End If
  End If
Next
k = dic.items
[e2] = k(dic.Count - 1)
End Sub

ZHLK

Sub jaofuan()
    Dim dic As Object, ar, row As Long, str1 As String
    Set dic = CreateObject("scripting.dictionary")
    row = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
    arr = ActiveSheet.Range("A1:A" & row)
    For i = 1 To UBound(arr)
        dic(ar(i, 1))= ""            
    Next
    ActiveSheet.Range("E2") = vba.join(dic.keys,",")
End Sub

wayne2705

多谢各位的帮助，问题已经解决。

wayne2705

发送重复了

wayne2705

发送重复了

wayne2705

前两次提交一直在转圈，以为失败了，第三次用高级模式提交马上就显示成功，唉。