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

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