求助个 合并数据，按数量来合并打包

今日123

在数据表里有详细的说明，还请大神出手相助 。在数据表里，数量 那一列 每20 为一箱合并数据， 20 * 4 后面的数字是 有多少个箱子，

xlj310

看似一个字段，实则AB列一起看，得出初步结果后再处理A列即可。

z865593849

第一列 你合并下单元格就行了

飞天篮球猪

插件解法...仅供参考...

xlj310

z865593849 发表于 2024-12-24 09:15
第一列 你合并下单元格就行了

1. Sub aaa()
   
2.     arr = [a1].CurrentRegion.Resize([a1].CurrentRegion.Rows.Count + 2) '多取两行
   
3.     ReDim brr(1 To 1000, 1 To 4)
   
4.     Dim 合并单元格地址 As String
   
5.     For i = 2 To UBound(arr) - 2
   
6.         a = arr(i, 1): b = arr(i, 2): c = arr(i, 3): d = arr(i, 4)
   
7.         qty = 1
   
8.         Do While b & c = arr(i + 1, 2) & arr(i + 1, 3) And arr(i + 1, 1) <> arr(i + 2, 1) And arr(i - 1, 1) <> arr(i, 1)
   
9.             a = a & "-" & arr(i + 1, 1)
   
10.             qty = qty + 1
    
11.             i = i + 1
    
12.         Loop
    
13.         r = r + 1
    
14.         brr(r, 1) = a
    
15.         If a Like "*-*" Then
    
16.             crr = Split(a, "-")
    
17.             a = crr(0) & "--" & crr(UBound(crr))
    
18.             brr(r, 1) = a 'IIf(Right(a, 2) = "*1", Left(a, Len(a) - 2), a)
    
19.         Else
    
20.             t = r
    
21.             Do While brr(t, 1) = brr(t - 1, 1)
    
22.                 t = t - 1
    
23.                 If t = 0 Then Exit Do
    
24.             Loop
    
25.             If t <> r Then
    
26.                 合并单元格地址 = 合并单元格地址 & "," & Cells(t, 1).Resize(r - t + 1).Address
    
27.             End If
    
28.         End If
    
29.         brr(r, 2) = b
    
30.         brr(r, 3) = c
    
31.         brr(r, 4) = d & "*" & qty
    
32.         If Right(brr(r, 4), 2) Like "*1" Then brr(r, 4) = Mid(brr(r, 4), 1, Len(brr(r, 4)) - 2)
    
33.     Next
    
34.     With [f3].Resize(r, 4)
    
35.         .Parent.[A1:D4].Copy .Offset(-1)
    
36.         .Resize(10000).Clear
    
37.         .Value = brr
    
38.         .Borders.LineStyle = xlContinuous
    
39.         .HorizontalAlignment = xlCenter
    
40.         If 合并单元格地址 <> "" Then
    
41.             With .Range(Mid(合并单元格地址, 2))
    
42.                 .Merge
    
43.                 .VerticalAlignment = xlCenter
    
44.             End With
    
45.         End If
    
46.     End With
    
47. End Sub

复制代码

翁知江安

Sub 合并统计()
Dim i, j, k, m, t, n, s, a, b, x, irow As Integer
Dim kk
Dim ar, br, cr As Variant
Dim d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
irow = Sheets("数据").[a65536].End(xlUp).Row
ar = Sheets("数据").[a1].CurrentRegion
d1(ar(2, 1)) = d1(ar(2, 1)) + 1
d2(ar(2, 2) & "," & ar(2, 3) & "," & ar(2, 4) & "," & ar(2, 1)) = ar(2, 4)
m = ar(2, 4)
t = 1
For i = 3 To irow
  d1(ar(i, 1)) = d1(ar(i, 1)) + 1
  If ar(i, 4) = 20 And ar(i - 1, 4) = ar(i, 4) And ar(i - 1, 2) = ar(i, 2) And ar(i - 1, 3) = ar(i, 3) Then
  m = m + ar(i, 4)
      d2.Remove ar(i - 1, 2) & "," & ar(i - 1, 3) & "," & ar(i - 1, 4) & "," & ar(i - 1, 1)
      d2(ar(i, 2) & "," & ar(i, 3) & "," & ar(i, 4) & "," & ar(i, 1)) = t & "—" & m / 20 + t - 1
   Else
     m = ar(i, 4): t = ar(i, 1)
     d2(ar(i, 2) & "," & ar(i, 3) & "," & ar(i, 4) & "," & ar(i, 1)) = t
   End If
Next
ReDim br(1 To d2.Count, 1 To 4)
For Each kk In d2.keys
  n = n + 1
  br(n, 1) = d2(kk)
  For s = 1 To 2
    br(n, s + 1) = Split(kk, ",")(s - 1)
  Next
   If Val(Split(kk, ",")(2)) = 20 Then
      a = WorksheetFunction.Find("—", br(n, 1))
      x = Len(br(n, 1))
      br(n, 4) = CStr(20 & "*" & Val(Right(br(n, 1), x - a)) - Val(Left(br(n, 1), a - 1)) + 1)
      Else
      br(n, 4) = Val(Split(kk, ",")(2))
   End If
Next
ReDim cr(1 To d2.Count, 1 To 4)
With Sheets("数据")
   .[p2].Resize(100, 4).Clear
   .[p2] = "盒子号": .[q2] = "规格": .[r2] = "度数": .[s2] = "数量"
   .[p3].Resize(d2.Count, 4) = br
For b = 3 To d2.Count + 2
  If d1(.Cells(b, 16).Value) > 1 Then
    .Cells(b, 16).Resize(d1(.Cells(b, 16).Value), 1).Merge
    End If
Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

今日123

翁知江安 发表于 2024-12-24 13:47
Sub 合并统计()
Dim i, j, k, m, t, n, s, a, b, x, irow As Integer
Dim kk

老师写的很符合在数据很多的时候。谢谢。好好研究下幸苦了

今日123

z865593849 发表于 2024-12-24 09:15
第一列 你合并下单元格就行了

谢谢幸苦了