如何实现一张表的明细数据按日期自动填入各表指定单元格内

dagal

不知道为什么 发表于 2018-8-5 00:39
伸手就来这很不好哦，3楼已经帮你代码了，自己变通下不可以？

改了好久，就啥也没出来。。。

dagal

1. Sub 应收账()
   
2. Dim Sht As Worksheet, I&, J&, Dic, Ar, Br, K&, S!
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     Ar = Sheets("应收账").Range("a1").CurrentRegion '30天的月份应清除32列数据
   
5.     ReDim Br(1 To UBound(Ar) - 1 + 3, 1 To 8)
   
6.     For I = 2 To UBound(Ar, 2)
   
7.         For J = 2 To UBound(Ar)
   
8.             If Ar(J, I) <> "" Then
   
9.             K = K + 1
   
10.                 Br(K, 3) = Ar(J, I): Br(K, 2) = Ar(J, 1)
    
11.                 S = Ar(J, I) + S
    
12.             End If
    
13.         Next
    
14.         Br(K + 1, 2) = "挂帐合计：": Br(K + 1, 3) = S
    
15.         K = K + 3
    
16.         S = 0
    
17.                 'Br(K, 1) = "备注"
    
18.                 If K > 0 Then
    
19.                     With Sheets("" & Day(Ar(1, I)) & "")
    
20.                         .Range("l8:p1000").clear
    
21.                         .Range("l8").Resize(K, 8) = Br
    
22.                         'With .Range("b5:i" & (K + 17))
    
23.                             ' .BorderAround xlContinuous, xlMedium
    
24.                             '.Borders.LineStyle = xlContinuous
    
25.                             '.Borders.ColorIndex = xlAutomatic
    
26.                        ' End With
    
27.                     End With
    
28.                 Else
    
29.                     With Sheets("" & Day(Ar(1, I)) & "")
    
30.                         .Range("l8:p1000").clear
    
31.                     End With
    
32.                 End If
    
33.                 ReDim Br(1 To UBound(Ar) - 1 + 3, 1 To 8)
    
34.             'Sheets (Day(Ar(1, I)))
    
35.         K = 0
    
36.     Next
    
37. End Sub

复制代码

已修改成功，但还是想问下这句后面的1 to 8是什么意思，好像这个在这里不起作用，我删除了又会出错。

jjmysjg

你7楼的附件与原来的附件不一样，使用12楼代码对吗

dagal

jjmysjg 发表于 2018-8-6 06:45
你7楼的附件与原来的附件不一样，使用12楼代码对吗

对的，我自己调试好了的