多列单元格内容合并到同行一个单元格内，删除重复值并计算个数

everbest2015

无非就是字典加数组

wwhao518

shuobude11 发表于 2019-10-17 15:16
改成这样呢，可以吗
Sub a()
Dim d As Object

这个也不行，没有先合并，是对G列的数据进行了统计，

xuemei0216

wwhao518 发表于 2019-10-17 14:26
大神，怎么每一行都会把上一行的累加啊，不要累加上一行的内容呢？

Sub a()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim arr
arr = [f2].CurrentRegion
[g2].Resize(UBound(arr), 2).ClearContents
Dim i&, j&, n&
For i = 1 To UBound(arr)
    For j = 4 To UBound(arr, 2)
        If arr(i, j) <> "" Then
            n = n + 1
            d(arr(i, j)) = ""
        End If
    Next
    Cells(i + 1, "g") = Join(d.keys, ".")
    Cells(i + 1, "h") = n
    n = 0
    d.RemoveAll
Next
Set d = Nothing
MsgBox "ok"
End Sub

shuobude11

xuemei0216 发表于 2019-10-17 16:31
Sub a()
Dim d As Object
Set d = CreateObject("scripting.dictionary")

我在你大神的基础上又改了一下，亲测是可以的，你再试试
Sub a()
Dim d As Object
Dim arr
Range("g：H").ClearContents
arr = [I2].CurrentRegion

Dim i&, j&, n&
For i = 1 To UBound(arr)
    Set d = CreateObject("scripting.dictionary")
         
     For j = 1 To UBound(arr, 2)
         If arr(i, j) <> "" Then
            
             d(arr(i, j)) = ""
         End If
     Next
     
     Cells(i + 1, "g") = Join(d.keys, ".")
     Cells(i + 1, "h") = d.Count
   
     Set d = Nothing
   
Next

MsgBox "ok"
End Sub

wwhao518

shuobude11 发表于 2019-10-18 09:45
我在你大神的基础上又改了一下，亲测是可以的，你再试试
Sub a()
Dim d As Object

是的，可以了，但是G列单元格的字母+数字没有按从小到大排序，

wwhao518

shuobude11 发表于 2019-10-18 09:45
我在你大神的基础上又改了一下，亲测是可以的，你再试试
Sub a()
Dim d As Object

我在你的基础上加了代码，你帮看看是不是这样
Sub JUKIIS排序()
Dim d As Object
Dim arr
Range("g：H").ClearContents
arr = [I2].CurrentRegion

Dim i&, j&, n&
For i = 1 To UBound(arr)
    Set d = CreateObject("scripting.dictionary")
         
     For j = 1 To UBound(arr, 2)
         If arr(i, j) <> "" Then
            
             d(arr(i, j)) = ""
         End If
     Next
     
     Cells(i + 1, "g") = Join(d.keys, ".")
     Cells(i + 1, "h") = d.Count
   
     Set d = Nothing
   
Next

arr = Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row)
Set reg = CreateObject("vbscript.regexp")
With reg
    .Pattern = "\d+"
    .Global = True
    For i = 1 To UBound(arr)
        If InStr(arr(i, 1), ".") Then
            brr = Split(arr(i, 1), ".")
            For j = 0 To UBound(brr) - 1
                For k = j + 1 To UBound(brr)
                    br1 = Val(.Execute(brr(j))(0))
                    br2 = Val(.Execute(brr(k))(0))
                    If br1 > br2 Then
                        temp = brr(j)
                        brr(j) = brr(k)
                        brr(k) = temp
                    End If
                Next
            Next
            arr(i, 1) = Join(brr, ".")
        End If
    Next
End With
[g2].Resize(UBound(arr), 1) = arr

MsgBox "OK！"

End Sub

shuobude11

wwhao518 发表于 2019-10-22 16:28
我在你的基础上加了代码，你帮看看是不是这样
Sub JUKIIS排序()
Dim d As Object

可以是可以，但是运行完要10秒呢

sjl_fyl

，留脚步学习~

everbest2015

Sub demo()
    Dim ar, br()
    Dim i&, j&, s$
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    With Sheet1
        .Range("G:H").ClearContents
        ar = .UsedRange.Value
        ReDim br(1 To UBound(ar), 1 To 2)
        br(1, 1) = "去重后": br(1, 2) = "次数"
        For i = 2 To UBound(ar)
            For j = 9 To UBound(ar, 2)
                s = ar(i, j)
                If s <> "" Then
                    If d.exists(s) = False Then
                       d(s) = ""
                    End If
                End If
            Next
            br(i, 1) = Join(d.keys, "、")
            br(i, 2) = UBound(d.keys) + 1
            d.RemoveAll
        Next
        .[g1].Resize(i - 1, 2) = br
    End With
End Sub