求助如何实现行列数不定的情况下进行数据汇总

dagal

应收款明细.rar (35.01 KB, 下载次数: 13)

2018-10-17 18:39 上传

点击文件名下载附件

1、因公司每个月应收账款较多，需要进行汇总，原来是手工将每一张表的最后一行合计数粘到汇总表里，但人员太多，主要是每个人员挂账的月份不同，有的人3月份还未回款，有的人就1-2个月。能否实现自动汇总，形成附件中汇总表的形式。
2、汇总1是要对所有人员所有单位的账单领取、开票情况进行汇总，目的在于可以快捷的跟踪营销员是否及时催收款项。

谢谢

lsc900707

分表不统一造成汇总困扰。

dagal

是啊，李老师，不知这样的情况能有什么解决办法吗？

liulang0808

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     arr = Array("姓名", "期初余额", "本月消费", "本月收回", "期末数", "预收款项", "1月", "2月", "3月", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "应收额", "备注")
   
5.     For j = 0 To UBound(arr)
   
6.         d(arr(j)) = j + 1
   
7.     Next j
   
8.     a = 3
   
9.     With Sheets("汇总")
   
10.         .UsedRange.Offset(1).Delete
    
11.         [a2].Resize(1, UBound(arr) + 1) = arr
    
12.         For Each sht In Sheets
    
13.             If InStr(sht.Name, "汇总") = 0 Then
    
14.                 arr = sht.UsedRange
    
15.                 For j = 2 To UBound(arr)
    
16.                     If InStr(arr(j, 1), "合计") > 0 Then
    
17.                         .Cells(a, 1) = sht.Name
    
18.                         For i = 1 To UBound(arr, 2)
    
19.                             If VBA.IsDate(arr(2, i)) Then
    
20.                                 m = Month(arr(2, i)) & "月"
    
21.                             Else
    
22.                                 m = arr(2, i)
    
23.                             End If
    
24.                             If d.exists(m) Then
    
25.                                 .Cells(a, d(m)) = arr(j, i)
    
26.                             End If
    
27.                         Next i
    
28.                         a = a + 1
    
29.                         Exit For
    
30.                     End If
    
31.                 Next j
    
32.             End If
    
33.         Next sht
    
34.         For j = 7 + 11 To 7 Step -1
    
35.             If .Cells(Rows.Count, j).End(3).Row = 2 Then Columns(j).Delete
    
36.             
    
37.         Next j
    
38.     End With
    
39.    
    
40.     Application.ScreenUpdating = True
    
41. End Sub

复制代码

liulang0808

附件内容供参考。。。。。。

dagal

liulang0808 发表于 2018-10-17 20:43
附件内容供参考。。。。。。

版主，谢谢！上半部分可以了，只是“其他”这张工作表的是从第3行到合计都要汇总过来，然后有个小计，所有人名下也要有一行小计，最后是总计。就是与我原来的表得一样才行。麻烦再帮忙看看。

汇总1的又如何实现呢？

lsc900707

dagal 发表于 2018-10-17 20:34
是啊，李老师，不知这样的情况能有什么解决办法吗？

1. Sub gj23w98()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     For Each sht In Sheets
   
4.         If InStr(sht.Name, "汇总") = 0 Then
   
5.             arr = sht.UsedRange
   
6.             For i = 3 To UBound(arr)
   
7.                 For j = 2 To UBound(arr, 2) - 2
   
8.                     If sht.Name <> "其他" And InStr(arr(i, 1), "合计") Then
   
9.                         s = sht.Name & arr(2, j)
   
10.                     ElseIf sht.Name = "其他" And arr(i, 1) <> "合计" Then
    
11.                         s = arr(i, 1) & arr(2, j)
    
12.                      End If
    
13.                      d(s) = arr(i, j)
    
14.                 Next
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     brr = ActiveSheet.UsedRange
    
19.     For i = 3 To UBound(brr) - 1
    
20.         For j = 2 To UBound(brr, 2)
    
21.             If InStr(brr(i, 1), "小计") = 0 Then
    
22.                 s = brr(i, 1) & brr(2, j)
    
23.                 if d.exists(s) then Cells(i, j) = d(s)
    
24.             End If
    
25.         Next
    
26.     Next
    
27. End Sub

复制代码

lsc900707

dagal 发表于 2018-10-17 20:34
是啊，李老师，不知这样的情况能有什么解决办法吗？

代码在审核，先测试第一个代码吧：

dagal

lsc900707 发表于 2018-10-17 21:10
代码在审核，先测试第一个代码吧：

谢谢，测试可以，不知汇总的小计金额出不来呢？为何在汇总的备注一列后面会多出些没用的内容，看了一下，都是第一张表里的M列的部分内容也给抓取过来了

lsc900707

dagal 发表于 2018-10-17 21:20
谢谢，测试可以，不知汇总的小计金额出不来呢？为何在汇总的备注一列后面会多出些没用的内容，看了一下， ...

我代码没有处理日期的，但是实际表格的日期要统一一下的，否则出错。