多行汇总求和某列合并不重复项

Qs18

Sub test()
    Dim arr, brr, dic, i, j
    arr = Sheet1.Range("a1").CurrentRegion.Value
    ReDim brr(1 To UBound(arr), 1 To 7)
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        s = arr(i, 1) & arr(i, 4)
        If Not dic.exists(s) Then
            m = m + 1
            dic(s) = m
            For j = 1 To 7
                brr(m, j) = arr(i, j)
            Next
        Else
            r = dic(s)
            If InStr(brr(r, 7), arr(i, 7)) < 1 Then
                brr(r, 7) = brr(r, 7) & "," & arr(i, 7)
            End If
        End If
    Next
    Sheet2.Range("a2").Resize(m, 7) = brr
    Beep
End Sub

Qs18

试试..............

Qs18

试一下.............

转角处的沉思

Qs18 发表于 2024-6-22 13:51
试试..............

感谢帮助，不过截图部分第四行F列数量为2，补充解释如截图，整理的时候先小范围对（A,D,G）列去重累加，后大范围对整体重复的A,D,F列合并G列。可能这样描述会清晰点。

转角处的沉思

quqiyuan 发表于 2024-6-22 12:07

感谢不辞辛劳研究，正常来说不会出现这种情况，如果是这种情况整理规则也是一样的，首先对ADG列相同的进行去重累加F列，然后再对刚刚累加后的数据G列不同但A,D,F列均相同的做G列对应的行仅保留一组重复的内容并合并G列数据。

转角处的沉思

quqiyuan 发表于 2024-6-22 12:07

首先先对A,D,G列均相同的行去重累加F列后.再对A，D,F列相同，G列不同的情况下做进一步处理，G列不同值对应的所有行内容是整体重复的，只有G列的值不同，所以此时就需要整体去重仅保留每组重复值的一行内容（同时对G列数值加逗号隔开合并）。

转角处的沉思

shiruiqiang 发表于 2024-6-22 07:41
把相关列1和相关列4作为字典

后来想想是否应该需要把相关列1&4&7作为字典先去重累加，然后再对相关列1&4&6作为字典取唯一值同时合并第7列。

ykcbf1100

楼主表述的有点问题，让人一下子看不明白。其实就是排重汇总了。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.22
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("Sheet1").UsedRange
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 1) <> Empty Then
   
8.             s = arr(i, 1) & "|" & arr(i, 4)
   
9.             If Not d.exists(s) Then
   
10.                 m = m + 1
    
11.                 d(s) = m
    
12.                 For j = 1 To UBound(arr, 2)
    
13.                     brr(m, j) = arr(i, j)
    
14.                 Next
    
15.             Else
    
16.                 r = d(s)
    
17.                 brr(r, 6) = brr(r, 6) + 1
    
18.                 brr(r, 7) = IIf(InStr(brr(r, 7), arr(i, 7)), brr(r, 7), brr(r, 7) & "," & arr(i, 7))
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     With Sheets("结果")
    
23.         .UsedRange.Offset(1).Clear
    
24.         .[a2].Resize(m, UBound(arr, 2)) = brr
    
25.         .[a2].Resize(m, UBound(arr, 2)).Borders.LineStyle = 1
    
26.     End With
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    
30. 
    

复制代码

转角处的沉思

ykcbf1100 发表于 2024-6-22 19:57
楼主表述的有点问题，让人一下子看不明白。其实就是排重汇总了。

感谢草爷帮助，言简意赅，不过结果第四五行的数据不用全部累加的，只需对G列相同的累加一次，G列不同A,D,F列相同做去重只合并G列。其实本次要的不是简单的排重汇总，我最开始描述可能不太明确，实际应该是先对A,D,G列相同的做一次汇总累加，再对A,D,F列相同的做去重汇总G列（此时的F列不做累加）