清华大佬耗费三个月吐血整理的几百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 |