【VBA研究】数据透视表巧算赶发率(达标率)

作者:iamlaosong

根据导出的收寄信息和轨迹信息,对照发车时限,判断邮件是否及时赶发。首先根据上述信息生成一张邮件列表,其中是否及时赶发用“0”和“1”两个数值表示,“1”表示及时赶发,然后再通过这张列表生成数据透视表,对是否及时赶发这个字段计算平均值,这个平均值就是及时赶发率,这个计算方法是不是比较巧妙?如下图:

数据透视表刷新语句如下:

Sheets("赶发率").PivotTables("数据透视表1").PivotCache.Refresh

完整的处理程序如下:

'---------------------------------------------------------
' 功能:根据导出轨迹信息进行赶发率统计
' 日期:2020年1月13日开始
' 版本:20200115
'---------------------------------------------------------

Dim DatFile As String

' 从导出的轨迹信息和收寄信息生成邮件列表并判断邮件是否及时发出
Sub get_mail()
    Dim mails(), trace(), limit()
    
    thisfile = ThisWorkbook.name   '本文件的名字,这样赋值就可以随便改名了
    Worksheets("系统参数").Select
    If Cells(3, 2) = "Y" Or Cells(5, 2) = "y" Then                              '导出出库文件
        Application.ScreenUpdating = True
    Else
        Application.ScreenUpdating = False
    End If
    
    CRFCJZSJ = "12:00"                  '次日发车截止时间:计划时间在此之前的默认次日发车
    '清理统计结果工作表
    stname = "邮件"
    maxrow = Sheets(stname).UsedRange.Rows.Count
    If maxrow > 1 Then
        Sheets(stname).Range("A2:L" & maxrow).ClearContents
    End If
    '收寄信息所在列:邮件号 收寄地市 收寄县市 寄达省 寄达地市 寄达县市 收寄时间
    yjhm_col = 1
    sjcs_col = 6
    sjxs_col = 8
    jdsf_col = 18
    jdcs_col = 20
    jdxs_col = 22
    sjsj_col = 13
    
    DatFile = Cells(5, 2)                        '收寄信息文件名称
    lineno = OpenFile(DatFile)
    If lineno = 0 Then Exit Sub
    mails = Range("A1:V" & lineno)               '读取目标列:A-V列
    ActiveWindow.Close
    DatFile = Cells(6, 2)                        '轨迹信息文件名称
    maxrow = OpenFile(DatFile)
    If maxrow = 0 Then Exit Sub
    '先邮件号码和时间排序,因为导出的轨迹数据有点乱,不是按照时间顺序来的
    Range("A1:D" & maxrow).Sort key1:=Range("A2"), order1:=xlAscending, key2:=Range("B2"), order2:=xlAscending, Header:=xlGuess
    trace = Range("A1:D" & maxrow)               '读取目标列:A-D列
    ActiveWindow.Close SaveChanges:=False
    
    '邮件号码居然是数值型,转为字符型先
    For i = 2 To lineno
        mails(i, yjhm_col) = CStr(mails(i, yjhm_col))
    Next i
    '读取时限,非当前工作表要加上Value这个关键字
    limitno = Sheets("时限").[A65536].End(xlUp).Row
    limit = Sheets("时限").Range("A1:E" & limitno).Value               '读取目标列:A-E列

    yjhm = "iamlaosong"
    mailno = 1
    mailno_tc = 0
    
    row1 = 2
    Do While row1 <= maxrow
        If trace(row1, 1) <> yjhm Then
            '新邮件
            yjhm = trace(row1, 1)
            sjcs = "notfound"
            sjxs = "notfound"
            jdsf = "notfound"
            errmsg = ""
            '提取收寄信息
            For i = 2 To lineno
                If yjhm = mails(i, yjhm_col) Then
                    sjcs = mails(i, sjcs_col)
                    sjxs = mails(i, sjxs_col)
                    jdsf = mails(i, jdsf_col)
                    jdcs = mails(i, jdcs_col)
                    jdxs = mails(i, jdxs_col)
                    sjsj = mails(i, sjsj_col)
                    If mails(i, sjcs_col) = mails(i, jdcs_col) Then
                        '同城邮件剔除
                        mailno_tc = mailno_tc + 1
                    Else
                        mailno = mailno + 1
                        Sheets(stname).Cells(mailno, 1) = mailno - 1
                        Sheets(stname).Cells(mailno, 2) = yjhm
                        Sheets(stname).Cells(mailno, 3) = sjcs
                        Sheets(stname).Cells(mailno, 4) = sjxs
                        Sheets(stname).Cells(mailno, 5) = jdsf
                        Sheets(stname).Cells(mailno, 6) = jdcs
                        Sheets(stname).Cells(mailno, 7) = jdxs
                        Sheets(stname).Cells(mailno, 8) = sjsj
                    End If
                    Exit For
                End If
            Next i
            If i > lineno Then errmsg = errmsg & "无收寄信息"
        End If
        ltfcsj = ""
        xsfcsj = ""
        csfcsj = ""
        If sjcs <> jdcs Then
            '非同城邮件:提取封车信息,取消收寄县市后面的县、市(因为时限表中和轨迹信息中都不带这些字眼)
            If InStr(sjxs, "区") > 0 Then sjxs = sjcs           '如果是区,则改为市
            
            '取消收寄市县名称后面的“市”或“县”,只有两个字的名字,“县”这个字还是要的,如和县、泾县、萧县等
            If Len(sjxs) > 2 And (Right(sjxs, 1) = "市" Or Right(sjxs, 1) = "县") Then
                sjxs = Left(sjxs, Len(sjxs) - 1)
            End If
            If Len(sjcs) > 2 And Right(sjcs, 1) = "市" Then
                sjcs = Left(sjcs, Len(sjcs) - 1)
            End If
            Do While trace(row1, 1) = yjhm
                If csfcsj = "" Then
                    'Debug.Print trace(row1, 3) & "--" & trace(row1, 4)
                    If trace(row1, 4) = "揽投发运/封车" Then
                        ltfcsj = trace(row1, 2)
                    ElseIf trace(row1, 4) = "处理中心封车" Then
                        If InStr(trace(row1, 3), sjcs) > 0 Then
                            csfcsj = trace(row1, 2)
                        ElseIf InStr(trace(row1, 3), sjxs) > 0 Or InStr(trace(row1, 3), "收投服务部") > 0 Then
                            '县中心往往用的是收投服务部名称,以第一个时间为准
                            If xsfcsj = "" And csfcsj = "" Then xsfcsj = trace(row1, 2)
                        End If
                    End If
                End If
                row1 = row1 + 1
                If row1 > maxrow Then
                    Exit Do
                End If
            Loop
            
            '实际发车时间sjfcsj
            If csfcsj <> "" Then
                sjfcsj = csfcsj
            ElseIf xsfcsj <> "" Then
                sjfcsj = xsfcsj
            Else
                sjfcsj = ltfcsj
                errmsg = errmsg & "离开揽投部时间"
            End If
            
            '判断是否及时发车==================
            If sjfcsj = "" Then
                sfjs = 0
                errmsg = errmsg & "无收寄局发车信息"
            ElseIf DateValue(sjfcsj) > DateValue(sjsj) + 1 Then
                '隔天以后发车
                sfjs = 0
            Else
                '取消收寄达县名称后面的“市”或“县”
                If Len(jdxs) > 2 And (Right(jdxs, 1) = "市" Or Right(jdxs, 1) = "县") Then
                    jdxs = Left(jdxs, Len(jdxs) - 1)
                End If
                If Len(jdcs) > 2 And Right(jdcs, 1) = "市" Then
                    jdcs = Left(jdcs, Len(jdcs) - 1)
                End If
               
                '规范省份名称,除了内蒙古和黑龙江是3个字外,其他都是2个字
                If Left(jdsf, 2) = "内蒙" Or Left(jdsf, 2) = "黑龙" Then
                    jdsf = Left(jdsf, 3)
                Else
                    jdsf = Left(jdsf, 2)
                End If
                '查询计划发车时间
                jhfcsj = ""
                If Left(yjhm, 1) = "1" Then
                    jhfcsj_col = 3
                Else
                    jhfcsj_col = 5
                End If
                xsfcsj = ""
                csfcsj = ""
                sffcsj = ""
                tyfcsj = ""
                '按收寄县市查时限表
                For kk = 2 To limitno
                    If limit(kk, 1) = sjxs Then
                        If InStr(limit(kk, jhfcsj_col - 1), jdxs) > 0 Then
                            xsfcsj = limit(kk, jhfcsj_col)
                        ElseIf InStr(limit(kk, jhfcsj_col - 1), jdcs) > 0 Then
                            csfcsj = limit(kk, jhfcsj_col)
                        ElseIf InStr(limit(kk, jhfcsj_col - 1), jdsf) > 0 Then
                            sffcsj = limit(kk, jhfcsj_col)
                        ElseIf limit(kk, jhfcsj_col - 1) = "*" Then
                            tyfcsj = limit(kk, jhfcsj_col)
                            Exit For
                        End If
                    End If
                Next kk
                '没有找到县市计划时间,以所属城市发车时间为准
                If kk > limitno Then
                    For k = 2 To limitno
                        If limit(k, 1) = sjcs Then
                            If InStr(limit(k, jhfcsj_col - 1), jdxs) > 0 Then
                                xsfcsj = limit(k, jhfcsj_col)
                            ElseIf InStr(limit(k, jhfcsj_col - 1), jdcs) > 0 Then
                                csfcsj = limit(k, jhfcsj_col)
                            ElseIf InStr(limit(k, jhfcsj_col - 1), jdsf) > 0 Then
                                sffcsj = limit(k, jhfcsj_col)
                            ElseIf limit(k, jhfcsj_col - 1) = "*" Then
                                tyfcsj = limit(k, jhfcsj_col)
                                Exit For
                            End If
                        End If
                    Next k
                    If k > limitno Then errmsg = errmsg & "无计划发车时间"
                End If
                
                '按从小到大的原则匹配发车时间
                If xsfcsj <> "" Then
                    jhfcsj = xsfcsj
                ElseIf csfcsj <> "" Then
                    jhfcsj = csfcsj
                ElseIf sffcsj <> "" Then
                    jhfcsj = sffcsj
                Else
                    jhfcsj = tyfcsj
                End If
                
                '判断当日和次日发车的是否及时赶发
                If DateValue(sjfcsj) > DateValue(sjsj) Then
                    '次日发车
                    If jhfcsj < TimeValue(CRFCJZSJ) And TimeValue(sjfcsj) < jhfcsj Then
                        sfjs = 1
                    Else
                        sfjs = 0
                    End If
                Else
                    '当日发车
                    If jhfcsj < TimeValue(CRFCJZSJ) Then
                        sfjs = 1
                    Else
                        If TimeValue(sjfcsj) <= jhfcsj Then
                            '及时发车
                            sfjs = 1
                        Else
                            sfjs = 0
                        End If
                    End If
                End If
            End If
            Sheets(stname).Cells(mailno, 9) = sjfcsj
            Sheets(stname).Cells(mailno, 10) = jhfcsj
            Sheets(stname).Cells(mailno, 11) = sfjs
            Sheets(stname).Cells(mailno, 12) = errmsg
        Else
            '同城邮件跳过
            Do While trace(row1, 1) = yjhm
                row1 = row1 + 1
                If row1 > maxrow Then
                    Exit Do
                End If
            Loop
        End If   '
        
        Application.StatusBar = "完成:" & Round(row1 * 100 / maxrow, 2) & "%"
    Loop        'row1

    Cells(5, 3) = "成功"
    Cells(6, 3) = "成功"
    Application.StatusBar = "就绪"
    Sheets("赶发率").PivotTables("数据透视表1").PivotCache.Refresh
    
    Application.ScreenUpdating = True
    MsgBox "邮件统计完毕,共" & mailno_tc + mailno - 1 & "件,其中非同城邮件" & mailno - 1 & "件!", vbOKOnly, "iamlaosong"
    
End Sub


'打开文件
Function OpenFile(fname As String) As Long
    FullName = ThisWorkbook.Path & "\" & fname
    If Dir(FullName, vbNormal) <> vbNullString Then
        If Right(fname, 3) = "log" Then
            Workbooks.OpenText Filename:=FullName, Origin:=936, StartRow:=1, DataType:=xlDelimited, Tab:=True
            Columns("A:A").Select
            Selection.NumberFormatLocal = "000000"
            Columns("A:F").Select
            Selection.Columns.AutoFit
        Else
            Workbooks.Open Filename:=FullName
        End If
        'If Application.Version >= "12.0" And ActiveWorkbook.FileFormat = 51 Then
        '    maxrow = Cells(1048576, pos_ems).End(xlUp).Row
        'Else
        '    maxrow = Cells(65536, pos_ems).End(xlUp).Row
        'End If
        OpenFile = Range("A" & Rows.Count).End(xlUp).Row
    Else
        MsgBox "数据文件不存在!", vbOKOnly, "iamlaosong"
        OpenFile = 0
    End If
End Function

'---------------------------------------------------------
' 功能:检查统计所需的数据文件是否存在
' 作者:宋定才
' 日期:2012年5月21日
' 版本:20120521
'---------------------------------------------------------
Sub checkfile()
    For num = 5 To 50
        DatFile = Cells(num, 2)    '文件名称
        If DatFile <> vbNullString Then
            FullName = ThisWorkbook.Path & "\" & DatFile
            If Dir(FullName, vbNormal) <> vbNullString Or Dir(FullName, vbDirectory) <> vbNullString Then
                Cells(num, 3) = "正常"
            Else     '文件不存在
                Cells(num, 3) = "失败"
            End If
        End If
    Next num
End Sub




 

发布了343 篇原创文章 · 获赞 260 · 访问量 326万+
展开阅读全文

没有更多推荐了,返回首页

©️2019 CSDN 皮肤主题: 大白 设计师: CSDN官方博客

分享到微信朋友圈

×

扫一扫,手机浏览