【VBA研究】數據透視表巧算趕發率（達標率）

作者：iamlaosong

根據導出的收寄信息和軌跡信息，對照發車時限，判斷郵件是否及時趕發。首先根據上述信息生成一張郵件列表，其中是否及時趕發用“0”和“1”兩個數值表示，“1”表示及時趕發，然後再通過這張列表生成數據透視表，對是否及時趕發這個字段計算平均值，這個平均值就是及時趕發率，這個計算方法是不是比較巧妙？

之所以這麼說是因爲數據透視表是無法理解透視結果進行計算。比如趕發率=趕髮量/郵件量，這兩個量都是透視表的求和結果，是不能放在計算字段中的（計算字段只能用數據源中的字段）。因爲及時趕發取值1，否則取值0，計算這個字段的平均值，就是相當於計算“趕髮量/郵件量”。如下圖：

數據透視表刷新語句如下：

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