作者：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