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