统计相同的单元格数量并把指定的单元格连续的数字加隔断

zhwy1

如图显示，把有很多行的前四列是相同的，（Size尺码)不同的，要把前四个相同的单元格中的不同尺码数量统计出来，并且把后面不同的值汇总在一起，不是相加，是汇总显示到一个单元格里面，如果汇总出来的数字是连续则加"-"隔断。请大神帮忙看看是否能实现。下图是原表：

下图是需要实现的数据统计：

kevinchengcw

试下

zhwy1

kevinchengcw 发表于 2019-10-22 11:06
试下

大哥，你发的图片呀，，不过还是谢谢你，我试试吧

zhwy1

kevinchengcw 发表于 2019-10-22 11:06
试下

我写了一遍，运行了一下，显示“下标越界”，大神帮忙看看。
Sub TrayToCarReport()
Dim Arr, Result, N&, I&, T&, R&, Str$, Dic As Object
With ThisWorkbook.Worksheets("数据表")
    Arr = .Range("a2:f" & .Cells(.Rows.Count, 1).End(3).Row).Value
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.comparemode = vbTextCompare
ReDim Result(LBound(Arr) To UBound(Arr), 1 To 6)
For N = LBound(Arr) To UBound(Arr)
    Str = Arr(N, 2) & vbTab & Arr(N, 3) & vbTab & Arr(N, 4) & vbTab & Arr(N, 5)
    If Not Dic.exists(Str) Then
        R = R + 1
        For I = 1 To 4
            Result(R, I) = Arr(N, I + 1)
        Next I
        Dic(Str) = R
    End If
    Result(Dic(Str), 6) = Result(Dic(Str), 6) + 1
    Result(Dic(Str), 5) = Result(Dic(Str), 5) & "" & Arr(N, 6)
Next N
For N = LBound(Result) To R
    Arr = Split(Trim(Result(N, 5)), "")
    For I = LBound(Arr) To UBound(Arr) - 1
        For T = I + 1 To UBound(Arr)
            If Val(Arr(I)) > Val(Arr(T)) Then
                Str = Arr(I): Arr(I) = Arr(T): Arr(T) = Str
            End If
        Next T
    Next I
    Str = Arr(LBound(Arr))
    T = 0
    For I = LBound(Arr) + 1 To UBound(Arr)
        If Val(Arr(I)) - Val(Arr(I - 1)) > 1 Then
            If Right(Str, 1) = "-" Then Str = Str & Arr(I - 1)
            Str = Str & "," & Arr(I)
        Else
            If Right(Str, 1) <> "-" Then Str = Str & "-"
            If I = UBound(Arr) Then Str = Str & Arr(I)
        End If
    Next I
    If Str <> "" And Right(Str, 1) = "-" Then Str = Left(Str, Len(Str) - 1)
    Result(N, 5) = Str
Next N
With ThisWorkbook.Worksheets("数据统计")
    .[h2].Resize(R, UBound(Result, 2)).Value = Result
End With
Set Dic = Nothing
End Sub

我写了一遍，运行了一下，显示“下标越界”，大神帮忙看看。

kevinchengcw

Sub test()
Dim Arr, Result, N&, I&, T&, R&, Str$, Dic As Object
With ThisWorkbook.Worksheets("数据表")
    Arr = .Range("a2:f" & .Cells(.Rows.Count, 1).End(3).Row).Value
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.comparemode = vbTextCompare
ReDim Result(LBound(Arr) To UBound(Arr), 1 To 6)
For N = LBound(Arr) To UBound(Arr)
    Str = Arr(N, 2) & vbTab & Arr(N, 3) & vbTab & Arr(N, 4) & vbTab & Arr(N, 5)
    If Not Dic.exists(Str) Then
        R = R + 1
        For I = 1 To 4
            Result(R, I) = Arr(N, I + 1)
        Next I
        Dic(Str) = R
    End If
    Result(Dic(Str), 6) = Result(Dic(Str), 6) + 1
    Result(Dic(Str), 5) = Result(Dic(Str), 5) & " " & Arr(N, 6)
Next N
For N = LBound(Result) To R
    Arr = Split(Trim(Result(N, 5)), " ")
    For I = LBound(Arr) To UBound(Arr) - 1
        For T = I + 1 To UBound(Arr)
            If Val(Arr(I)) > Val(Arr(T)) Then
                Str = Arr(I): Arr(I) = Arr(T):  Arr(T) = Str
            End If
        Next T
    Next I
    Str = Arr(LBound(Arr))
    T = 0
    For I = LBound(Arr) + 1 To UBound(Arr)
        If Val(Arr(I)) - Val(Arr(I - 1)) > 1 Then
            If Right(Str, 1) = "-" Then Str = Str & Arr(I - 1)
            Str = Str & "," & Arr(I)
        Else
            If Right(Str, 1) <> "-" Then Str = Str & "-"
            If I = UBound(Arr) Then Str = Str & Arr(I)
        End If
    Next I
    If Str <> "" And Right(Str, 1) = "-" Then Str = Left(Str, Len(Str) - 1)
    Result(N, 5) = Str
Next N
With ThisWorkbook.Worksheets("数据统计")
    .[h2].Resize(R, UBound(Result, 2)).Value = Result
End With
Set Dic = Nothing
End Sub

excel玉米

功力尚浅，贻笑大方了。见附件。
Sub test()
   Dim arr, brr, i, s, k, list, m, y
   Set dic = CreateObject("scripting.dictionary")
   arr = Sheets("数据表").Range("A1").CurrentRegion
   ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 2)
   For i = 1 To UBound(arr)
     list = arr(i, 1) & "_" & arr(i, 2) & "_" & arr(i, 3) & "_" & arr(i, 4) & "_" & arr(i, 5)
     If dic.exists(list) Then
       s = dic(list)
       If Val(arr(i, 6)) - Val(brr(s, 8)) = 1 Then
         If Len(brr(s, 6)) - VBA.InStrRev(brr(s, 6), ",") > 7 Then
           y = Len(brr(s, 6)) - 5
           brr(s, 6) = Left(brr(s, 6), y) & "-" & arr(i, 6)
           brr(s, 7) = brr(s, 7) + 1
           brr(s, 8) = arr(i, 6)
         Else
          brr(s, 6) = brr(s, 6) & "-" & arr(i, 6)
          brr(s, 7) = brr(s, 7) + 1
          brr(s, 8) = arr(i, 6)
        End If
        Else
        brr(s, 6) = brr(s, 6) & "," & arr(i, 6)
        brr(s, 7) = brr(s, 7) + 1
        brr(s, 8) = arr(i, 6)
       End If
     Else
       k = k + 1
       dic(list) = k
       brr(k, 1) = arr(i, 1)
       brr(k, 2) = arr(i, 2)
       brr(k, 3) = arr(i, 3)
       brr(k, 4) = arr(i, 4)
       brr(k, 5) = arr(i, 5)
       brr(k, 6) = arr(i, 6)
       brr(k, 7) = 1
       brr(k, 8) = arr(i, 6)
     End If
   Next
      brr(1, 7) = "Num"
   Sheets("数据统计").Range("A1").CurrentRegion.Clear
   Sheets("数据统计").Range("A1").Resize(k, 7) = brr
     Set arr = Nothing
     Set brr = Nothing
End Sub

ggmmlol

TrayToCarReport.rar (21 KB, 下载次数: 2)

2019-10-22 18:50 上传

点击文件名下载附件

zhwy1

kevinchengcw 发表于 2019-10-22 11:06
试下

我需要把这个 Customer PO 也统计进去，因为有时候数据表里面 第一列也会有不同，大概如下图，谢谢老哥
帮我改一下吧，把数据表里面的第一列的条件也加进去吧。


TrayToCarReport11111.zip (13.59 KB, 下载次数: 3)

2019-10-24 10:01 上传

点击文件名下载附件

kevinchengcw

1. Sub test()
   
2. Dim Arr, Result, N&, I&, T&, R&, Str$, Dic As Object
   
3. With ThisWorkbook.Worksheets("数据表")
   
4.     Arr = .Range("a2:f" & .Cells(.Rows.Count, 1).End(3).Row).Value
   
5. End With
   
6. Set Dic = CreateObject("scripting.dictionary")
   
7. Dic.comparemode = vbTextCompare
   
8. ReDim Result(LBound(Arr) To UBound(Arr), 1 To 7)
   
9. For N = LBound(Arr) To UBound(Arr)
   
10.     Str = Arr(N, 1) & vbTab & Arr(N, 2) & vbTab & Arr(N, 3) & vbTab & Arr(N, 4) & vbTab & Arr(N, 5)
    
11.     If Not Dic.exists(Str) Then
    
12.         R = R + 1
    
13.         For I = 1 To 5
    
14.             Result(R, I) = Arr(N, I)
    
15.         Next I
    
16.         Dic(Str) = R
    
17.     End If
    
18.     Result(Dic(Str), 7) = Result(Dic(Str), 7) + 1
    
19.     Result(Dic(Str), 6) = Result(Dic(Str), 6) & " " & Arr(N, 6)
    
20. Next N
    
21. For N = LBound(Result) To R
    
22.     Arr = Split(Trim(Result(N, 6)), " ")
    
23.     For I = LBound(Arr) To UBound(Arr) - 1
    
24.         For T = I + 1 To UBound(Arr)
    
25.             If Val(Arr(I)) > Val(Arr(T)) Then
    
26.                 Str = Arr(I): Arr(I) = Arr(T):  Arr(T) = Str
    
27.             End If
    
28.         Next T
    
29.     Next I
    
30.     Str = Arr(LBound(Arr))
    
31.     T = 0
    
32.     For I = LBound(Arr) + 1 To UBound(Arr)
    
33.         If Val(Arr(I)) - Val(Arr(I - 1)) > 1 Then
    
34.             If Right(Str, 1) = "-" Then Str = Str & Arr(I - 1)
    
35.             Str = Str & "," & Arr(I)
    
36.         Else
    
37.             If Right(Str, 1) <> "-" Then Str = Str & "-"
    
38.             If I = UBound(Arr) Then Str = Str & Arr(I)
    
39.         End If
    
40.     Next I
    
41.     If Str <> "" And Right(Str, 1) = "-" Then Str = Left(Str, Len(Str) - 1)
    
42.     Result(N, 6) = Str
    
43. Next N
    
44. With ThisWorkbook.Worksheets("数据统计")
    
45.     .[h2].Resize(R, UBound(Result, 2)).Value = Result
    
46. End With
    
47. Set Dic = Nothing
    
48. End Sub

复制代码

ggmmlol

Carton No都在4位数以内，所以可以利用单元格区域的合并来完成连续的No的合并，

1. Sub test()
   
2.     Dim ar, s$, c%, dic As Object, n%, j%, p%, tmp, tt
   
3.     ar = Sheet1.Range("A1").CurrentRegion
   
4.     c = UBound(ar, 2)
   
5.     ReDim br(1 To UBound(ar, 1), 1 To c + 1)
   
6.     Set dic = CreateObject("Scripting.Dictionary")
   
7.     For i = 1 To UBound(ar)
   
8.         s = ar(i, 1) & "/" & ar(i, 2) & "/" & ar(i, 3) & "/" & ar(i, 4) & "/" & ar(i, 5)
   
9.         If dic.exists(s) Then
   
10.             p = dic(s)
    
11.         Else
    
12.             n = n + 1: dic(s) = n: p = n
    
13.             For j = 1 To c - 1
    
14.                 br(n, j) = ar(i, j)
    
15.             Next
    
16.         End If
    
17.         br(p, c) = br(p, c) & "," & ar(i, c)
    
18.         br(p, c + 1) = br(p, c + 1) + 1
    
19.     Next
    
20.     br(1, c + 1) = "Num"
    
21.     For i = 2 To n
    
22.         br(i, c) = Mid(Replace(br(i, c), ",", ",A"), 2)
    
23.         tmp = Split(Replace(Union(Range(br(i, c)), Range(br(i, c))).Address, "$A$", ""), ",")
    
24.         For j = 0 To UBound(tmp)
    
25.             tt = Split(tmp(j), ":")
    
26.             For k = 0 To UBound(tt)
    
27.                 tt(k) = Format(tt(k), "0000")
    
28.             Next
    
29.             tmp(j) = Join(tt, "-")
    
30.         Next
    
31.         br(i, c) = Join(tmp, ",")
    
32.     Next
    
33.     Sheet2.Range("K1").Resize(n, c + 1) = br
    
34. End Sub

复制代码