[已解决]月合计不按公历（月初至月末）计算时VB代码应如何修改

zsd5237

见附件说明。

最佳答案

月排行榜 / 总排行榜

mxg825

2011-10-13 15:50

Sub 插入合计行()
Dim K%, S%
Dim mydate As Date '分隔日期（每月25号）
K = 9: S = 9
mydate = CDate(Format(Cells(K, 2), "YYYY-MM-") & 25)
Application.ScreenUpdating = False '关闭刷新 提高速度
Do
If (CDate(Cells(K, 2)) <= mydate And CDate(Cells(K + 1, 2)) > mydate ) OR (Len(Cells(K + 1, 2)) = 0) Then '合计项
Rows(K + 1 & ":" & K + 2).Insert '插入2行
Cells(K + 1, 5) = Format(mydate, "M月") & "合计"
Range(Cells(K + 1, 7), Cells(K + 1, 10)) = "=sum(r" & S & "c:r[-1]c)"
Cells(K + 2, 5) = "本年合计"
Range(Cells(K + 2, 7), Cells(K + 2, 10)) = "=sumif(r9c5:r[-1]c5, ""*月合计"",r9c:r[-1]c)"
Range(Cells(K + 1, 2), Cells(K + 2, 13)).Interior.ColorIndex = 40 '填充底色
Cells(K + 1, 2).Resize(2, 12).Font.Bold = True '加粗字体 （Resize 扩大区域） 返回区域与上句一样
K = K + 2: S = K + 1
mydate = DateAdd("M", 1, mydate) '下一个月的25号
End If
K = K + 1
Loop Until Cells(S, 2) = ""
Range("B9").Resize(K - 9, 12).Borders.LineStyle = 1 '加网格线
Application.ScreenUpdating = True '开启刷新
MsgBox "完成"
End Sub
'代码加了一个条件 当到最后个单元格时， (Len(Cells(K + 1, 2)) = 0)
'Loop Until Cells(K, 2) = ""   K 改为S

跳转到最佳答案楼层

studyexcel

回复 zsd5237 的帖子

跟你的年合计一样，用sumif判断下日期范围就行了吧。。RC的表示法我很晕

zsd5237

年合计同月合计相同，从上一年的12月26日至本年的12月25日为一年，表内的本年合计实质上是从属于本月合计，即将本月合计相加。

mxg825

zsd5237 发表于 2011-10-12 22:49
见附件说明。

If Day(Cells(k, 2)) = 25 And Day(Cells(k + 1, 2)) = 26 Then  '合计项

当前行是 25号 下一行是26号  就插入合计行

mxg825

如果日期可能没有25,26号，把楼上的条件改成，小于或等于25,大于或等于26

zsd5237

mxg825 发表于 2011-10-13 00:28
如果日期可能没有25,26号，把楼上的条件改成，小于或等于25,大于或等于26

成功。但有一个问题：当月26日至月末（指公历日期）无数据时（见附件表2红字数据行），就没有上月的2个合计行。请mxg825老师想想办法。

mxg825

回复 zsd5237 的帖子

1. Private Sub CommandButton1_Click()
   
2. With CommandButton1
   
3.     If .Caption = "删除合计行" Then
   
4.         Call 删除合计行
   
5.        .Caption = "生成合计行"
   
6.     Else
   
7.         Call 插入合计行
   
8.        .Caption = "删除合计行"
   
9.     End If
   
10. End With
    
11. End Sub

复制代码

1. Sub 插入合计行()
   
2. Dim K%, S%
   
3. Dim mydate As Date '分隔日期（每月25号）
   
4. K = 9: S = 9
   
5. mydate = CDate(Format(Cells(K, 2), "YYYY-MM-") & 25)
   
6. Application.ScreenUpdating = False '关闭刷新 提高速度
   
7. Do
   
8.   If CDate(Cells(K, 2)) <= mydate And CDate(Cells(K + 1, 2)) > mydate Then '合计项
   
9.      Rows(K + 1 & ":" & K + 2).Insert '插入2行
   
10.      Cells(K + 1, 5) = Format(mydate, "M月") & "合计"
    
11.      Range(Cells(K + 1, 7), Cells(K + 1, 10)) = "=sum(r" & S & "c:r[-1]c)"
    
12.      Cells(K + 2, 5) = "本年合计"
    
13.      Range(Cells(K + 2, 7), Cells(K + 2, 10)) = "=sumif(r9c5:r[-1]c5, ""*月合计"",r9c:r[-1]c)"
    
14.      Range(Cells(K + 1, 2), Cells(K + 2, 13)).Interior.ColorIndex = 40 '填充底色
    
15.      Cells(K + 1, 2).Resize(2, 12).Font.Bold = True '加粗字体  （Resize 扩大区域） 返回区域与上句一样
    
16.      K = K + 2: S = K + 1
    
17.      mydate = DateAdd("M", 1, mydate) '下一个月的25号
    
18.   End If
    
19. K = K + 1
    
20. Loop Until Cells(K, 2) = ""
    
21. Range("B9:M" & K - 1).Borders.LineStyle = 1 '加网格线
    
22. Application.ScreenUpdating = True '开启刷新
    
23. MsgBox "完成"
    
24. End Sub

复制代码

1. Sub 删除合计行()
   
2. K = Range("E65536").End(xlUp).Row
   
3. Application.ScreenUpdating = False '关闭刷新 提高速度
   
4. Do
   
5. If InStr(Cells(K, 5), "合计") > 0 Then Rows(K).Delete
   
6. K = K - 1
   
7. Loop Until K = 9
   
8. Application.ScreenUpdating = True '开启刷新
   
9. End Sub
   

复制代码

zsd5237

mxg825老师：这次模块修改很有创意，一个按扭执行了二个模块，同时解决了我在6楼所提出的问题，即：当月26日至月末（指公历日期）无数据时（见附件表2红字数据行），就没有上月的2个合计行的问题。目前存在的一个问题是：数据表中最后一个月的数据没有合计数据，只有等待26日以后的日期数据出现或下一个月的数据出现，才有合计项。这对于最近一个月的数据利用或 年底结帐时十分不便，能否将这个关键问题解决了，则这个模块再没有任何缺陷了。对不起，请别怪我多事，谢谢！

mxg825

Sub 插入合计行()
Dim K%, S%
Dim mydate As Date '分隔日期（每月25号）
K = 9: S = 9
mydate = CDate(Format(Cells(K, 2), "YYYY-MM-") & 25)
Application.ScreenUpdating = False '关闭刷新 提高速度
Do
If (CDate(Cells(K, 2)) <= mydate And CDate(Cells(K + 1, 2)) > mydate ) OR (Len(Cells(K + 1, 2)) = 0) Then '合计项
Rows(K + 1 & ":" & K + 2).Insert '插入2行
Cells(K + 1, 5) = Format(mydate, "M月") & "合计"
Range(Cells(K + 1, 7), Cells(K + 1, 10)) = "=sum(r" & S & "c:r[-1]c)"
Cells(K + 2, 5) = "本年合计"
Range(Cells(K + 2, 7), Cells(K + 2, 10)) = "=sumif(r9c5:r[-1]c5, ""*月合计"",r9c:r[-1]c)"
Range(Cells(K + 1, 2), Cells(K + 2, 13)).Interior.ColorIndex = 40 '填充底色
Cells(K + 1, 2).Resize(2, 12).Font.Bold = True '加粗字体 （Resize 扩大区域） 返回区域与上句一样
K = K + 2: S = K + 1
mydate = DateAdd("M", 1, mydate) '下一个月的25号
End If
K = K + 1
Loop Until Cells(S, 2) = ""
Range("B9").Resize(K - 9, 12).Borders.LineStyle = 1 '加网格线
Application.ScreenUpdating = True '开启刷新
MsgBox "完成"
End Sub
'代码加了一个条件 当到最后个单元格时， (Len(Cells(K + 1, 2)) = 0)
'Loop Until Cells(K, 2) = ""   K 改为S

zsd5237

谢谢你的鼓励！