楼主
芐雨 |
Q：通过B列的数字和值合并A列对应的单元格，并进行编号和分类出颜色
条件1： B列按编号求和，[0.9,1]之间合并A列单元格，填充为绿色；(1,1.1]之间合并A列单元格，填充为黄色
条件2： 同一编号，>1.1时，前面的单元格需合并A列单元格，填充为绿色。如：sum(B1:B2)<0.9 and sum(B1:B3)>1.1,合并A1:A2,填充为绿色
条件3： 剩余不符合的单元格合并，并填写相应的，如：A2:A4,A26:A28,A61等
A:代码如下:
- Sub 条件求和合并_芐雨()
- Dim d, t, adr()
- Set d = CreateObject("Scripting.Dictionary")
- On Error Resume Next
- Application.ScreenUpdating = False
- [A:A].Clear '清除D列
- Arr = [B1].CurrentRegion
- [A1].Resize(UBound(Arr), 1).Borders.LineStyle = 1 '加上边框
-
- ReDim adr(1 To UBound(Arr), 1 To 1)
- For i = 2 To UBound(Arr)
- If Arr(i, 4) <> Arr(i - 1, 4) Then '不等于上一个单元格时
- If m <> 0 And Not rng.MergeCells Then 'm不为0，且rng不为合并单元格
- With Range(Range(adr(m, 1)), Cells(i - 1, 1))
- .Merge
- .Value = Range(Range(adr(m, 1)), Cells(i - 1, 1)).Address(0, 0)
- End With
- End If
- m = m + 1 '每次到新的编号时，记录m,初始化n
- n = 1
- adr(m, 1) = Cells(i, 1).Address(0, 0) ' 记录单元格地址
- End If
-
- Set rng = Range(Range(adr(m, 1)), Cells(i, 1)) '记rng单元格区域
-
- If Not d.exists(Arr(i, 4)) Then
- d(Arr(i, 4)) = Arr(i, 1) '不存在arr(i,4)时
- Else
- d(Arr(i, 4)) = d(Arr(i, 4)) + Arr(i, 1) '已存在求和
- End If
-
- If i = UBound(Arr) Then '到最后一个时
- k = 0
- rng.Merge '合并单元格
- rng.Value = rng.Address(0, 0) '输出单元格地址
- Else
- k = Arr(i + 1, 1) 'k=下一个数组的值
- End If
-
- If (d(Arr(i, 4)) < 0.9 And d(Arr(i, 4)) + k _
- > 1.1) Or (d(Arr(i, 4)) >= 0.9 And d(Arr(i, 4)) <= 1) Then '（<0.9且加上k值大于1.1时）或（在[.9,1]内） 偏负
- rng.Merge '合并单元格
- rng.Interior.ColorIndex = 4 '显示为绿色
- rng(1) = Arr(i, 4) & Format(n, "00") '显示编号
- d(Arr(i, 4)) = 0 '初始化，字典重新计算求和值
- m = m + 1
- n = n + 1
- adr(m, 1) = Cells(i + 1, 1).Address(0, 0) '记录地址
- End If
-
- If d(Arr(i, 4)) > 1 And d(Arr(i, 4)) <= 1.1 Then '在（1,1.1]范围内，偏正值
- rng.Merge '合并单元格
- rng.Interior.ColorIndex = 6 '显示为黄色
- rng(1) = Arr(i, 4) & Format(n, "00") '显示编号
- d(Arr(i, 4)) = 0 '初始化，字典重新计算求和值
- m = m + 1
- n = n + 1
- adr(m, 1) = Cells(i + 1, 1).Address(0, 0) '记录地址
- End If
- Next
-
- [A:A].HorizontalAlignment = xlCenter '设置格式居中
- [A:A].VerticalAlignment = xlCenter
- Application.ScreenUpdating = True
- End Sub
 根据求和条件合并单元格.rar
|