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

dagal

附件中有一张应收明细，里面是按日期为列，单位为行，能否将明细数据按日期将单位和明细金额对应到各张表的D18、F18指定列的单元格中。如挂账单位超过3行的可自动向下延伸。
test.rar (25.62 KB, 下载次数: 58)

2018-7-30 16:56 上传

点击文件名下载附件

chaohuahch

应收账的工作表里面12~13行 A列的数据  洋浦伟业（福建）科技发展有限公司 完全是一样的。这是本来就需要的效果，还是重复了？

ione_fox

1. Sub test()
   
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, 2) = "挂账": Br(K, 3) = Ar(J, I): Br(K, 5) = 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("b18:I1000").Clear
    
21.                         .Range("b18").Resize(K, 8) = Br
    
22.                         With .Range("b5:i" & (K + 17))
    
23.                             .Borders.LineStyle = xlContinuous
    
24.                             .Borders.ColorIndex = xlAutomatic
    
25.                         End With
    
26.                     End With
    
27.                 Else
    
28.                     With Sheets("" & Day(Ar(1, I)) & "")
    
29.                         .Range("b18:I1000").Clear
    
30.                     End With
    
31.                 End If
    
32.                 ReDim Br(1 To UBound(Ar) - 1 + 3, 1 To 8)
    
33.             'Sheets (Day(Ar(1, I)))
    
34.         K = 0
    
35.     Next
    
36. End Sub
    

复制代码

dagal

chaohuahch 发表于 2018-7-30 17:12
应收账的工作表里面12~13行 A列的数据  洋浦伟业（福建）科技发展有限公司 完全是一样的。这是本来就需要的 ...

本来就需要的，按单位按明细挂账

dagal

ione_fox 发表于 2018-7-30 18:22

您好，程序是没问题了，但里面有几行是设定表格边框的，一旦数据进去后，表格边框就全变了，麻烦您能否再帮忙看看如何只将数据进去，边框还是保留原来的样子，因为这是要打印出来的，谢谢啦~~

dagal

.BorderAround xlContinuous, xlMedium已搞定，去掉中间定义的内边框和颜色，加入这句粗外边框即可

dagal

ione_fox 发表于 2018-7-30 18:22

另一个表也是需要将明细填入各张表中，可是我照着代码改了好久也没改成，大神您有空时再帮我看看吧，谢谢了~
班结表.rar (33.79 KB, 下载次数: 12)

2018-8-3 21:58 上传

点击文件名下载附件

dagal

请lsc900707老师有空再指教一下，谢谢

dagal

有哪位大神有空帮忙看下呀，谢谢了，不胜感激~~

不知道为什么

dagal 发表于 2018-8-4 23:15
有哪位大神有空帮忙看下呀，谢谢了，不胜感激~~

伸手就来这很不好哦，3楼已经帮你代码了，自己变通下不可以？