execl vba一个统计数据的报表模块

2015/07/21 40616

清华大佬耗费三个月吐血整理的几百G的资源，免费分享！....>>>

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
Attribute VB_Name = "reportcreate20130804"
'All Rights Reserved Deserved by 蓝宝石的傻话
 
Dim daq() As Variant
Dim dran()
Dim tran()
 
 
'定义函数统计每个数据表的情况
Function data_q(msheet As Worksheet, dnum As Variant, tname As Variant, dcode As Variant, dstatus As Variant)
 
dhead = Array("序号", "管理类型码", "单证名称", "流水号", "状态", "机构代码")
 
ReDim daq(UBound(dstatus), UBound(dnum))
' 初始化二维数组数据为0
For i = 0 To (UBound(dnum) - LBound(dnum))
    For j = 0 To (UBound(dstatus) - LBound(dstatus))
        daq(j, i) = 0
    Next
Next
'定义表6统计每个数据包的报废流水号，首先定义列数
r6 = 1
For i = 0 To Sheet6.UsedRange.Columns.Count
    If Len(Sheet6.Cells(1, r6)) <> 0 Then
        r6 = r6 + 1
    End If
Next
'载入数据表并且选择当前数据表
msheet.Select
'如果数据表中第一列不是序号，则插入序号列
If Cells(1, 1).Value <> dhead(0) Then
    Columns(1).Insert
    Cells(1, 1).Value = dhead(0)
End If
ReDim dran(UBound(dhead))
For x = 1 To msheet.UsedRange.Columns.Count
'统计选择的清单数据，第一步、把统计项目的对应列值整理出来
    For i = 0 To (UBound(dhead) - LBound(dhead))
        If InStr(Cells(1, x), dhead(i)) Then
            dran(i) = x
        End If
    Next
Next
'统计清单上各项目的状态值
For y = 2 To msheet.UsedRange.Rows.Count
    msheet.Cells(y, dran(4)).NumberFormatLocal = "@"
    msheet.Cells(y, dran(5)).NumberFormatLocal = "@"
'需要统计的项目
    For b = 0 To (UBound(dnum) - LBound(dnum))
'需要统计的状态
        For a = 0 To (UBound(dstatus) - LBound(dstatus))
            If InStr(msheet.Cells(y, dran(1)), dnum(b)) And (msheet.Cells(y, dran(4)).Value = dstatus(a) Or msheet.Cells(y, dran(4)).Value = dcode(a)) Then
'统计每个项目每个状态的数量，并填入序号
                daq(a, b) = daq(a, b) + 1
                Cells(y, 1).Value = daq(a, b)
'针对统计的项目在表6中生成对应的列
                Sheet6.Cells(1, r6 + b).Value = tname(b)
'统计作废的流水号并填入表6
                If InStr(msheet.Cells(y, dran(4)), "作废") Or msheet.Cells(y, dran(4)).Value = dcode(2) Or msheet.Cells(y, dran(4)).Value = dcode(3) Or msheet.Cells(y, dran(4)).Value = dcode(8) Then
                    Sheet6.Cells(2, r6 + b).Value = daq(2, b) + daq(3, b) + daq(8, b)
                    Sheet6.Cells(daq(a, b) + 2, r6 + b).NumberFormatLocal = "@"
                    Sheet6.Cells(daq(a, b) + 2, r6 + b).Value = msheet.Cells(y, dran(3)).Value
                End If
            End If
        Next
    Next
Next
 
End Function
 
'统计报表1的数据写入
Function data_write(tname As Variant)
'留作自动化报表使用（未编写）
'thead = Array("（1）月初库存", "（2）当月领用", "（3）正常使用", "（4）作废", "（5）遗失", "（7）月末实物库存")
Sheet1.Select
'将清单一的数据统计人工回收和系统回收相加，人工作废和作废相加后的数据写入报表
For y = 1 To Sheet1.UsedRange.Rows.Count
    For i = 0 To (UBound(tname) - LBound(tname))
        If Cells(y, 1).Value = tname(i) Then
            Sheet1.Cells(y, 2) = Sheet1.Cells(y, 10)
            Sheet1.Cells(y, 4).Value = daq(0, i) + daq(1, i) + daq(6, i) + daq(7, i)
            Sheet1.Cells(y, 5).Value = daq(2, i) + daq(3, i) + daq(8, i)
            Sheet1.Cells(y, 6).Value = daq(4, i) + daq(5, i)
        End If
    Next
Next
End Function
 
Function data2_write(dnum As Variant, tname As Variant, dstatus As Variant)
thead = Array("管理类型码", "单证名称", "版本号", "数量", "状态")
Sheet2.Select
'统计清单一数据第一步，把统计项目的对应列值扫出来
ReDim tran(UBound(thead))
For x = 1 To Sheet2.UsedRange.Columns.Count
    For i = 0 To (UBound(thead) - LBound(thead))
        If InStr(Cells(1, x), thead(i)) Then
            tran(i) = x
        End If
    Next
Next
 
'定义表2统计每个数据包的报废流水号，首先定义列数
r2 = 1
For i = 1 To Sheet2.UsedRange.Rows.Count
        r2 = i
Next
MsgBox r2
'将数据表统计出来的状态分类填写
'MsgBox UBound(dnum)
For i = 0 To (UBound(dnum) - LBound(dnum))
    For j = 0 To (UBound(dstatus) - LBound(dstatus))
     
        If InStr(tname(i), "外包") = 0 Then
            For y = 1 To Sheet2.UsedRange.Rows.Count
                If Sheet2.Cells(y, tran(0)).Value = dnum(i) And Sheet2.Cells(y, tran(4)).Value = dstatus(j) Then
                    Sheet2.Cells(y, tran(3)).Value = daq(j, i)
                End If
            Next
        ElseIf daq(j, i) <> 0 And InStr(tname(i), "外包") Then
'        MsgBox InStr(tname(i), "外包")
            r2 = r2 + 1
            Sheet2.Cells(r2 + i, tran(0)).Value = dnum(i)
            Sheet2.Cells(r2 + i, tran(1)).Value = tname(i)
            Sheet2.Cells(r2 + i, tran(2)).NumberFormatLocal = "@"
            Sheet2.Cells(r2 + i, tran(2)).Value = "0000"
            Sheet2.Cells(r2 + i, tran(3)).Value = daq(j, i)
            Sheet2.Cells(r2 + i, tran(4)).Value = dstatus(j)
        End If
    Next
Next
End Function
 
 
 
Sub report_create()
'0-未知;1-待入库;2-库存;3-未使用;4-人工回收;5-系统回收
'6-作废;7-系统作废;8-过期;9-超期登报遗失;10-挂失;11-遗失
'12-停用;13-预期废止;14-废止;15-系统删除;16-系统回收未激活;17-系统回收激活
'18-打印;19-中介发放未激活;20-未入库;22-过期作废
dcode = Array("4", "5", "6", "7", "9", "11", "16", "17", "22")
dstatus = Array("人工回收", "系统回收", "作废", "系统作废", "超期登报遗失", "遗失", "系统回收未激活", "系统回收激活", "过期作废")
 
dnum = Array("CN011", "FN20001", "PN011", "PN031", "YE001A", "YE012(8623)")
dnum1 = Array("FN20001")
 
tname = Array("理赔批单三联", "广东机打发票", "小批单", "团体保全人名清单（小）", "保单一联", "批单三联")
 
tname1 = Array("广东机打发票（外包出单中心）")
tname2 = Array("广东机打发票（邮政外包中心）")
 
Sheet6.UsedRange.Clear
 
'报表数据填入3、4、5项
Call data_q(Sheet3, dnum, tname, dcode, dstatus)
Call data_write(tname)
Call data2_write(dnum, tname, dstatus)
 
Call data_q(Sheet4, dnum1, tname1, dcode, dstatus)
Call data_write(tname1)
Call data2_write(dnum1, tname1, dstatus)
 
Call data_q(Sheet5, dnum1, tname2, dcode, dstatus)
Call data_write(tname2)
Call data2_write(dnum1, tname2, dstatus)
Sheet2.Select
End Sub