[已解决]按日期 车牌 取车 目的地 还车等多行数据合并成车辆的每日行驶路线一行数据

E直很D调

请教各位高手们帮忙看看，需要实现以下功能，vba代码应该如何写啊：
sheet1 是公司中每辆车每一天的行驶的明细记录（如下图），
sheet2 是汇总表

需要实现有3种汇总方式：

1.通过车牌汇总： 可以汇总指定车牌号的车辆的全部行驶记录；
2.通过时间段汇总：可以汇总指定时间段中公司所有车辆的行驶记录；
3.通过车牌+时间段汇总：可以汇总指定车辆在指定时间段的行驶记录；
这个是目前最迫切的希望高手们帮忙解决的
4.在Sheet2（汇总表）中的“L”列需要根据Sheet1（明细表）中的日期，汇总出车辆当天的行驶路线，并且每个地点间需要用
"-->"箭头分隔开，行车路线=取车地点“-->"目的地1"-->"目的地2”-->"目的地N”-->"还车地点
例如：
1月2日当天 车牌为粤ZN123港的车辆的取车地点是”深圳集团“，当天的”目的地“有”十五峰“，”加油站“，”海富中心“，”金中环“等，还车地点是深圳集团，那就合并成 ”深圳集团“-->"十五峰"-->"加油站“-->"海富中心"-->"金中环"-->"深圳集团"
这个样子。


现在把附件上传，希望高手们能多多帮忙，老板本月底要看的，目前就差这个合并地点成为路程的功能没能实现了 工作簿1.rar (157.8 KB, 下载次数: 14)

2015-1-13 17:51 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-1-14 14:20

1.     Dim T1 As Boolean, T2 As Boolean, T3 As Boolean
   
2.     arr = Sheet1.[b4].CurrentRegion
   
3.     cp = [c5]: rq1 = [h5]: rq2 = [j5]
   
4.     ReDim brr(1 To UBound(arr), 1 To 12)
   
5.     For i = 2 To UBound(arr)
   
6.         If Len(arr(i, 3)) = 0 Then arr(i, 3) = arr(i - 1, 3)    '出车日期
   
7.         If Len(arr(i, 8)) = 0 Then arr(i, 8) = arr(i - 1, 8)   '到达日期
   
8.         T1 = False: T2 = False: T3 = False    '筛选符合条件的记录
   
9.         If Len(cp) = 0 Or arr(i, 1) = cp Then T1 = True   '车牌
   
10.         If Len(rq1) = 0 Or arr(i, 3) >= rq1 Then T2 = True       '起始日期
    
11.         If Len(rq2) = 0 Or arr(i, 8) <= rq2 Then T3 = True       '结束日期
    
12.         If T1 = True And T2 = True And T3 = True Then   ' 车牌号、起始日期、结束日期都符合条件
    
13.             If arr(i, 13) = "取车" Then
    
14.                 n = n + 1
    
15.                 brr(n, 1) = arr(i, 3): brr(n, 2) = arr(i, 4): brr(n, 3) = arr(i, 5)        '出发日期、时间、出发地
    
16.                 brr(n, 9) = arr(i, 6)      '出车里程
    
17.                 xc = arr(i, 5)      '行程
    
18.             ElseIf arr(i, 13) = "还车" Then
    
19.                 brr(n, 5) = arr(i, 8): brr(n, 6) = arr(i, 9): brr(n, 7) = arr(i, 7)       '到达日期、时间、目的地
    
20.                 xc = xc & "→" & arr(i, 5) & "→" & arr(i, 7)          '行程
    
21.                 brr(n, 10) = arr(i, 10)      '还车里程
    
22.                 brr(n, 12) = brr(n, 10) - brr(n, 9)        '本次里程数
    
23.                 brr(n, 11) = xc         '行程
    
24.             Else
    
25.                 xc = xc & "→" & arr(i, 5)
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     [b11].Resize(100, 12).ClearContents
    
30.     [b11].Resize(n, 12) = brr
    
31. End Sub

复制代码

跳转到最佳答案楼层

水上漂123

简单一点的前三个可以数据透视表实现，第四个可以用公式

E直很D调

谢谢指点，前三个我用vba解决了，就是第4个功能不知道弄，由于是要汇总后打印出来给老板看的，所以最好是能vba”一键搞定“就好的

爱疯

数据透视表操作.rar (1.57 MB, 下载次数: 3)

2015-1-13 19:05 上传

点击文件名下载附件

这是数据透视表操作的gif，没照你说的去实现，仅为简单演示下。
你重新按自己的想法，去弄下吧，省事。

E直很D调

爱疯 发表于 2015-1-13 19:10
这是数据透视表操作的gif，没照你说的去实现，仅为简单演示下。
你重新按自己的想法，去弄下吧，省事。 ...

谢谢您的gif文档，透视图在汇总的时候确实很方便且直观，我的问题当中的前3个，我用VBA已经弄好了，现在就是第4个问题，搞了好几天，都没有头绪，有朋友说用字典的方法，但是我的把日期做为关键字时，又有空值，不知道该怎么弄，目前这是今年1月份几天的行车记录，以后数据多了，用公式的话可能会很慢，所以希望能用vba能搞定那个“行车路线”的问题
麻烦大神再帮忙想个法，谢谢啦！

grf1973

建个字典，车牌号+出车日期为key，路线连接为item（一般取出发地，如果有“还车”，再加上目的地）

grf1973

如果日期为空，就让日期等于上一单元格的日期就行了。

爱疯

Sub Click()
    Dim A, i%, j%, x%, y%, record, allRecord
    A = Sheet1.Range("b4").CurrentRegion

    For i = UBound(A) To 2 Step -1
        If y = 0 Then y = i    '更新终点
        If A(i, 3) <> "" Then
            '1）新增
            For j = i To y
                record = record & "→" & A(j, 5)
            Next j
            '2）累计
            allRecord = Mid(record, 2) & "," & allRecord
            '3）清空
            y = 0: record = ""
        End If
    Next i
    A = Split(Left(allRecord, Len(allRecord) - 1), ",")

    With Sheet3
        .Range("a1").CurrentRegion = ""
        .Range("a1").Resize(UBound(A) + 1) = Application.Transpose(A)
        .Activate
    End With
End Sub
1.rar (9.42 KB, 下载次数: 3)

2015-1-14 09:47 上传

点击文件名下载附件

说明的太多，有点眼花，是这样？

E直很D调

爱疯 发表于 2015-1-14 09:47
Sub Click()
    Dim A, i%, j%, x%, y%, record, allRecord
    A = Sheet1.Range("b4").CurrentRegion
...

谢谢爱疯的代码，差不多了，但是没有“还车地点”，还请麻烦再看看，您的附件是不是上传错了，不是我的那个文件啊？

grf1973

1.     Dim T1 As Boolean, T2 As Boolean, T3 As Boolean
   
2.     arr = Sheet1.[b4].CurrentRegion
   
3.     cp = [c5]: rq1 = [h5]: rq2 = [j5]
   
4.     ReDim brr(1 To UBound(arr), 1 To 12)
   
5.     For i = 2 To UBound(arr)
   
6.         If Len(arr(i, 3)) = 0 Then arr(i, 3) = arr(i - 1, 3)    '出车日期
   
7.         If Len(arr(i, 8)) = 0 Then arr(i, 8) = arr(i - 1, 8)   '到达日期
   
8.         T1 = False: T2 = False: T3 = False    '筛选符合条件的记录
   
9.         If Len(cp) = 0 Or arr(i, 1) = cp Then T1 = True   '车牌
   
10.         If Len(rq1) = 0 Or arr(i, 3) >= rq1 Then T2 = True       '起始日期
    
11.         If Len(rq2) = 0 Or arr(i, 8) <= rq2 Then T3 = True       '结束日期
    
12.         If T1 = True And T2 = True And T3 = True Then   ' 车牌号、起始日期、结束日期都符合条件
    
13.             If arr(i, 13) = "取车" Then
    
14.                 n = n + 1
    
15.                 brr(n, 1) = arr(i, 3): brr(n, 2) = arr(i, 4): brr(n, 3) = arr(i, 5)        '出发日期、时间、出发地
    
16.                 brr(n, 9) = arr(i, 6)      '出车里程
    
17.                 xc = arr(i, 5)      '行程
    
18.             ElseIf arr(i, 13) = "还车" Then
    
19.                 brr(n, 5) = arr(i, 8): brr(n, 6) = arr(i, 9): brr(n, 7) = arr(i, 7)       '到达日期、时间、目的地
    
20.                 xc = xc & "→" & arr(i, 5) & "→" & arr(i, 7)          '行程
    
21.                 brr(n, 10) = arr(i, 10)      '还车里程
    
22.                 brr(n, 12) = brr(n, 10) - brr(n, 9)        '本次里程数
    
23.                 brr(n, 11) = xc         '行程
    
24.             Else
    
25.                 xc = xc & "→" & arr(i, 5)
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     [b11].Resize(100, 12).ClearContents
    
30.     [b11].Resize(n, 12) = brr
    
31. End Sub

复制代码