根据支出记录和指定的结束日期用VBA批量生成月度记录

宽处行

半百 发表于 2025-11-3 10:26

老师,附件能上传一下么?

半百

1. Sub test()
   
2. ar = Sheets("支付明细").[a1].CurrentRegion
   
3. ReDim br(1 To UBound(ar) * 60, 1 To UBound(ar, 2) - 2)
   
4. For i = 2 To UBound(ar)
   
5.     For j = 1 To DateDiff("m", ar(i, 1), [o2]) + 1
   
6.         n = n + 1
   
7.         br(n, 1) = Application.Max(ar(i, 1), Application.EoMonth(ar(i, 1), j - 2) + 1)
   
8.         For k = 2 To UBound(br, 2)
   
9.             br(n, k) = ar(i, k + 2)
   
10.         Next
    
11.     Next
    
12. Next
    
13. Sheets(4).UsedRange.Offset(1).ClearContents
    
14. Sheets(4).[a2].Resize(n, UBound(br, 2)) = br
    
15. End Sub
    

复制代码

ynzsvt

标题顺序可以不一致的

宽处行

ynzsvt 发表于 2025-11-3 13:42
标题顺序可以不一致的

老师，我调试了半天，还是没办法改成想要的样子，不好意思，能帮我再看看么，按照我这个附件修改一下。


1、【支付明细】这张表的字段数能增减变动，程序能自己判断么？
2、【支付明细】表的字段和生产【利息计提】表的字段一样就好了。

laoye5403

宽处行 发表于 2025-11-3 15:24
老师，我调试了半天，还是没办法改成想要的样子，不好意思，能帮我再看看么，按照我这个附件修改一下。{: ...

这个应该可以满足你的要求.顺序位置可以不一样,但是字段的名称必须一致.

1. Sub 批量生成明细()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     ar = Sheets("支付明细").Range("a1").CurrentRegion
   
4.     Set Sh = Sheets("计提利息")
   
5.     br = Sh.Range("a1").CurrentRegion
   
6.     ReDim cr(1 To 100000, 1 To UBound(br, 2))
   
7.    
   
8.     a = CDate(Sheets("支付明细").[p2])
   
9.     For i = 1 To UBound(ar, 2)
   
10.         d(ar(1, i)) = i
    
11.     Next i
    
12.     For i = 2 To UBound(ar)
    
13.         a1 = DateSerial(Year(ar(i, 1)), Month(ar(i, 1)), 1)
    
14.         Do While a1 <= a
    
15.             n = n + 1
    
16.             For j = 1 To UBound(br, 2)
    
17.                 b = d(br(1, i))
    
18.                 If b <> "" Then cr(n, j) = ar(i, b)
    
19.             Next j
    
20.             cr(n, d("日期")) = a1
    
21.             a1 = DateAdd("m", 1, a1)
    
22.         Loop
    
23.     Next i
    
24.     Sh.[A2].Resize(n, UBound(br, 2)) = cr
    
25. End Sub

复制代码

ynzsvt

改了三处，见备注。

ynzsvt