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

ms967967

请各位VBA大老帮助实现如下效果，具体要求如附件

合并	数值	数1	数2	编号区域
A01	0.17	4	23	A
	0.11	5	45	A
	0.21	7	33	A
	0.22	10	45	A
	0.06	2	32	A
	0.27	12	45	A
A02	0.27	12	45	A
	0.27	12	45	A
	0.27	12	45	A
	0.22	10	45	A

最佳答案

月排行榜 / 总排行榜

tzjx200521

2014-2-9 19:00

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
    

复制代码

   看看这个吧

跳转到最佳答案楼层

dsmch

请用附件说明问题。

ms967967

条件求和后合并单元格.zip (11.23 KB, 下载次数: 7)

2014-2-9 09:17 上传

点击文件名下载附件
忘记加附件了

tzjx200521

1. Sub test()
   
2. Dim s As String, i As Long, cnt As Integer, m, n
   
3. For i = 4 To Range("e65536").End(3).Row
   
4. With Cells(i, "c")
   
5.      s = .Value
   
6.      cnt = .MergeArea.Count
   
7.      n = Cells(i, "d").Resize(cnt)
   
8.      m = WorksheetFunction.Sum(n)
   
9.      If m > 1 Then
   
10.      Cells(i, "c").Interior.Color = 65535
    
11.      Else
    
12.      Cells(i, "c").Interior.Color = 5287936
    
13.      End If
    
14.     Application.DisplayAlerts = False
    
15.     Cells(i, "d").Resize(cnt).Merge
    
16.     Cells(i, "d").Resize(cnt).Value = m
    
17.     Application.DisplayAlerts = True
    
18.      End With
    
19.      i = i + cnt - 1
    
20. Next
    
21. End Sub
    

复制代码

请楼主测试，如果可以请给个最佳  呵呵

ms967967

tzjx200521 发表于 2014-2-9 15:51
请楼主测试，如果可以请给个最佳  呵呵

感谢您的帮助，与我的要求有些差异，
我的要求是不改变D列的数值，合并C列对应的单元格。如果能参考G列的信息对合并后的C列单元格进行编号就更完美了

tzjx200521

1. Sub test()
   
2. Dim s As String, i As Long, cnt As Integer, m, n
   
3. For i = 4 To Range("e65536").End(3).Row
   
4. With Cells(i, "c")
   
5.      s = .Value
   
6.      cnt = .MergeArea.Count
   
7.      n = Cells(i, "d").Resize(cnt)
   
8.      m = WorksheetFunction.Sum(n)
   
9.      If m > 1 Then
   
10.      Cells(i, "c").Interior.Color = 65535
    
11.      Else
    
12.      Cells(i, "c").Interior.Color = 5287936
    
13.      End If
    
14.      End With
    
15.      i = i + cnt - 1
    
16. Next
    
17. End Sub
    

复制代码

那更简单啊。。是不是这样？？？

tzjx200521

1. Sub test()
   
2. Dim s As String, i As Long, cnt As Integer, m, n, k
   
3. For i = 4 To Range("e65536").End(3).Row
   
4. With Cells(i, "c")
   
5.      k = k + 1
   
6.      s = .Value
   
7.      cnt = .MergeArea.Count
   
8.      n = Cells(i, "d").Resize(cnt)
   
9.      m = WorksheetFunction.Sum(n)
   
10.      If m > 1 Then
    
11.      Cells(i, "c").Interior.Color = 65535
    
12.      Else
    
13.      Cells(i, "c").Interior.Color = 5287936
    
14.      End If
    
15.      Cells(i, "c").Resize(cnt).Value = Cells(i, "g") & Format(k, "000")
    
16.      End With
    
17.      i = i + cnt - 1
    
18. Next
    
19. End Sub
    
20. 
    

复制代码

又改了下  这个按楼主要求写了个编号

ms967967

tzjx200521 发表于 2014-2-9 16:43
那更简单啊。。是不是这样？？？

可能我没有将事情说清楚。
       实际应用时，D列的数值经常会有调整。所对应的C列单元格也要跟据D列的变化进行调整。（也就是说这次：C4：C9合并，如果C8变为0.3，那么VBA刷新后就是C4：C8合并）

tzjx200521

ms967967 发表于 2014-2-9 16:57
可能我没有将事情说清楚。
       实际应用时，D列的数值经常会有调整。所对应的C列单元格也要跟据D列的 ...

按你这么说变绿色和黄色是干嘛？？？？？

ms967967

tzjx200521 发表于 2014-2-9 17:01
按你这么说变绿色和黄色是干嘛？？？？？

主要是合并和加编号
调整颜色是想直观的看到有几个大于1，几个小于1，这个要求如果麻烦可以不考虑。
给您填麻烦了，请多费心了