[已解决]VBA根据致贫原因，生成各种原因报销表

yjwdjfqb

VBA根据致贫原因，生成各种原因报销表
请老师们帮帮忙，做下这个，用于精准扶贫报表，谢谢大家了！
如图：




VBA自动生成.rar (9.39 KB, 下载次数: 6)

2016-12-12 08:42 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-12-13 14:37

1. Sub 生成报销表()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.    
   
5.     arr = Sheets(2).[a1].CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         xm = arr(i, 2) & arr(i, 3) & arr(i, 4) '姓名
   
8.         d(xm) = i
   
9.     Next
   
10.    
    
11.     brr = Sheets(1).[a1].CurrentRegion
    
12.     For i = 2 To UBound(brr)
    
13.         yy = brr(i, 7)  '原因
    
14.         xm = brr(i, 2) & brr(i, 3) & brr(i, 4)
    
15.         If d.exists(xm) Then d1(yy) = d1(yy) & "," & d(xm)
    
16.     Next
    
17.    
    
18.     Call 删除
    
19.     For Each yy In d1.keys
    
20.         Sheets(2).Copy after:=Sheets(Sheets.Count)
    
21.         With ActiveSheet
    
22.             .Name = yy & "-报销表"
    
23.             .[a2:r1000].ClearContents
    
24.             .[a2:r1000].Borders.LineStyle = 0
    
25.             xrr = Split(d1(yy), ",")
    
26.             ReDim crr(1 To UBound(xrr), 1 To UBound(arr, 2))
    
27.             For i = 1 To UBound(xrr)
    
28.                 For j = 1 To UBound(arr, 2)
    
29.                     crr(i, j) = arr(xrr(i), j)
    
30.                 Next
    
31.             Next
    
32.             .[a2].Resize(i - 1, UBound(arr, 2)) = crr
    
33.             .[a2].Resize(i - 1, UBound(arr, 2)).Borders.LineStyle = 1
    
34.         End With
    
35.     Next
    
36.     Sheets(1).Activate
    
37. End Sub
    
38. 
    
39. Sub 删除()
    
40.     Application.DisplayAlerts = False
    
41.     For Each sh In Worksheets
    
42.         If sh.Index > 2 Then sh.Delete
    
43.     Next
    
44.     Application.DisplayAlerts = True
    
45. End Sub
    

复制代码

跳转到最佳答案楼层

yjwdjfqb

请老师们帮帮忙，谢谢大家了！

爱疯

工具：http://www.excelpx.com/thread-386168-1-1.html
如果急的话，可用这个工具拆分。
如果不急，那等其它朋友有空后来帮忙吧。
能否以"医疗证号码"，作为两个表的不重复项？


步骤：
1）比如，在S列建一个辅助列。s2=INDEX(致贫原因!G:G,MATCH(G2,致贫原因!H:H,))
2）对S列拆分。
3）由于不是为此题而写的，所以拆分后需手动修改分表的名称。
VBA自动生成_拆分后的.rar (10.86 KB, 下载次数: 3)

2016-12-12 16:09 上传

点击文件名下载附件

grf1973

1. Sub 生成报销表()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.    
   
5.     arr = Sheets(2).[a1].CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         xm = arr(i, 2) & arr(i, 3) & arr(i, 4) '姓名
   
8.         d(xm) = i
   
9.     Next
   
10.    
    
11.     brr = Sheets(1).[a1].CurrentRegion
    
12.     For i = 2 To UBound(brr)
    
13.         yy = brr(i, 7)  '原因
    
14.         xm = brr(i, 2) & brr(i, 3) & brr(i, 4)
    
15.         If d.exists(xm) Then d1(yy) = d1(yy) & "," & d(xm)
    
16.     Next
    
17.    
    
18.     Call 删除
    
19.     For Each yy In d1.keys
    
20.         Sheets(2).Copy after:=Sheets(Sheets.Count)
    
21.         With ActiveSheet
    
22.             .Name = yy & "-报销表"
    
23.             .[a2:r1000].ClearContents
    
24.             .[a2:r1000].Borders.LineStyle = 0
    
25.             xrr = Split(d1(yy), ",")
    
26.             ReDim crr(1 To UBound(xrr), 1 To UBound(arr, 2))
    
27.             For i = 1 To UBound(xrr)
    
28.                 For j = 1 To UBound(arr, 2)
    
29.                     crr(i, j) = arr(xrr(i), j)
    
30.                 Next
    
31.             Next
    
32.             .[a2].Resize(i - 1, UBound(arr, 2)) = crr
    
33.             .[a2].Resize(i - 1, UBound(arr, 2)).Borders.LineStyle = 1
    
34.         End With
    
35.     Next
    
36.     Sheets(1).Activate
    
37. End Sub
    
38. 
    
39. Sub 删除()
    
40.     Application.DisplayAlerts = False
    
41.     For Each sh In Worksheets
    
42.         If sh.Index > 2 Then sh.Delete
    
43.     Next
    
44.     Application.DisplayAlerts = True
    
45. End Sub
    

复制代码

hhzjxss

哈哈，VBA与与日俱增，搞起扶贫来了！
我给它起了个名字，叫《VBA与精确扶贫》

yjwdjfqb

hhzjxss 发表于 2016-12-15 20:20
哈哈，VBA与与日俱增，搞起扶贫来了！

实际应用，发挥作用。

emmahhm

学习学习