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

wwhao518

请教各位大神，如何把同行例如图上2行I后面的所有列的数据合并到G2，并删除重复值从大到小的顺序以“."号隔开，并计算出有多少个数值到H2，最好能够一次性完成GH列所有结果。

约定的童话

又是一个搞SMT的很好奇你I列后面的内容怎么来的？机器直接导的？

wwhao518

约定的童话 发表于 2019-10-16 14:31
又是一个搞SMT的很好奇你I列后面的内容怎么来的？机器直接导的？

是的，同行吗？想弄个站位表快捷的方法

约定的童话

wwhao518 发表于 2019-10-16 14:35
是的，同行吗？想弄个站位表快捷的方法

xuemei0216

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
Next
Set d = Nothing
MsgBox "ok"
End Sub

小鹿一样

在目标工作表后新加一个sheet作为辅助。
Sub stat()
For i = 2 To 31
ThisWorkbook.Sheets(1).Cells(i, 8) = WorksheetFunction.CountA(ThisWorkbook.Sheets(1).Rows(i)) - 5
m = ThisWorkbook.Sheets(1).Cells(i, 9).End(xlToRight).Column
ThisWorkbook.Sheets(1).Range(Sheets(1).Cells(i, 9), Sheets(1).Cells(i, m)).Copy
ThisWorkbook.Sheets(2).Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
ThisWorkbook.Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(m - 8, 1)).RemoveDuplicates Columns:=1, Header:=xlNo
r = ThisWorkbook.Sheets(2).Cells(Rows.Count, 1).End(3).Row
ThisWorkbook.Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(r, 1)).Sort key1:=ThisWorkbook.Sheets(2).Range("a1"), Order1:=xlDescending, Header:=xlNo
arr = ThisWorkbook.Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(r, 1))
If r = 1 Then
ThisWorkbook.Sheets(1).Cells(i, 7) = ThisWorkbook.Sheets(1).Cells(i, 9)
Else
ThisWorkbook.Sheets(1).Cells(i, 7) = Join(Application.Transpose(arr), ".")
ThisWorkbook.Sheets(2).Cells.Clear
End If
Next
End Sub

wwhao518

小鹿一样 发表于 2019-10-17 09:19
在目标工作表后新加一个sheet作为辅助。
Sub stat()
For i = 2 To 31

太感谢了，你的方法可以合并去重复并完成统计，但是统计的右边的，其实我想要的是合并后的G列单元格内的以“."分隔的字母+数字有多少个到H列。另外，这个好像只能2—31行，如果下面继续还有数据就要更改代码了，能不能不限制行和列。帮忙再改一下好吗？谢谢

wwhao518

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

大神，怎么每一行都会把上一行的累加啊，不要累加上一行的内容呢？

shuobude11

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

改成这样呢，可以吗
Sub a()
Dim d As Object

Dim arr
arr = [f2].CurrentRegion
[g2].Resize(UBound(arr), 2).ClearContents
Dim i&, j&, n&
For i = 1 To UBound(arr)
Set d = CreateObject("scripting.dictionary")
     For j = 4 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

everbest2015

无非就是字典加数组