[已解决]数据条件求和后合并

tzjx200521

看看行不行

1. Sub BH()
   
2. Dim s As String, i As Long, cnt As Integer, m, n, k
   
3. Range("c4:c" & Range("c65536").End(3).Row).UnMerge
   
4. For i = 4 To Range("d65536").End(3).Row
   
5.    For cnt = 1 To Range("d65536").End(3).Row
   
6.    n = Cells(i, "d").Resize(cnt)
   
7.      m = WorksheetFunction.Sum(n)
   
8.      If m > 1 Then
   
9.      k = k + 1
   
10.       Application.DisplayAlerts = False
    
11.    Cells(i, "c").Resize(cnt).Merge
    
12.    Cells(i, "c").Value = Cells(i, "g") & Format(k, "000")
    
13.   Application.DisplayAlerts = True
    
14.   i = i + cnt - 1
    
15.      GoTo 100
    
16.      End If
    
17.      Next
    
18. i = i + cnt - 1
    
19. 100: Next
    
20. Cells(cnt - 1, "c") = Cells(cnt - 1, "g") & Format(k + 1, "000")
    
21. End Sub
    

复制代码

tzjx200521

1. Dim Arr, i&, j&, aa, h, ks, js, n&, k
   
2. Sub lqxs()
   
3. Dim d, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. With [d:d]
   
7.     .ClearContents
   
8.     .UnMerge
   
9.     .Interior.ColorIndex = xlNone
   
10. End With
    
11. Arr = [e3].CurrentRegion
    
12. [d3].Resize(UBound(Arr), 1).Borders.LineStyle = 1
    
13. For i = 2 To UBound(Arr)
    
14.     d(Arr(i, 4)) = d(Arr(i, 4)) & i & ","
    
15. Next
    
16. k = d.keys: t = d.items
    
17. For i = 0 To UBound(k)
    
18.     t(i) = Left(t(i), Len(t(i)) - 1): n = 0
    
19.     If InStr(t(i), ",") Then
    
20.         aa = Split(t(i), ",")
    
21.         ks = aa(0) + 2: h = 0
    
22.         For j = 0 To UBound(aa)
    
23.             h = h + Arr(aa(j), 1)
    
24.             If Abs(h - 1) < 0.1 Then
    
25.                 js = aa(j) + 2
    
26.                 Call yy
    
27.                 If j + 1 <= UBound(aa) Then ks = aa(j + 1) + 2
    
28.             ElseIf h > 1 Then
    
29.                 js = aa(j - 1) + 2
    
30.                 h = h - Arr(aa(j), 1)
    
31.                 Call yy
    
32.                 If j + 1 <= UBound(aa) Then ks = aa(j) + 2: h = Arr(aa(j), 1)
    
33.             Else
    
34.                 GoTo 100
    
35.             End If
    
36. 100:
    
37.         Next
    
38.     Else
    
39.     End If
    
40. Next
    
41. If h <> 0 Then js = UBound(Arr) + 2: Call yy
    
42. End Sub
    
43. Sub yy()
    
44. Dim ys
    
45. If h > 1 Then
    
46.     ys = 6
    
47. ElseIf h < 1 Then
    
48.     ys = 4
    
49. End If
    
50. With Cells(ks, 4).Resize(js - ks + 1, 1)
    
51.     .Merge
    
52.     n = n + 1
    
53.     .Value = Arr(ks - 2, 4) & Format(n, "00")
    
54.     .Interior.ColorIndex = ys: h = 0
    
55. End With
    
56. End Sub
    

复制代码

   看看这个吧

ms967967

非常感谢您的支持。{:091:}