Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2182|回复: 3

[已解决]VBA 提取数据出现的最终时间

[复制链接]
发表于 2017-5-8 23:02 | 显示全部楼层 |阅读模式
本帖最后由 jk0932 于 2017-10-11 10:35 编辑

如附件,需要提取最晚出现的时间;
最佳答案
2017-5-9 14:04
  1. Sub aaa()
  2. Dim arr, i&, brr, r&
  3. arr = Sheets(1).Range("a2:c" & Sheets(1).[b65536].End(3).Row)
  4. ReDim brr(1 To UBound(arr), 1 To 3)
  5. For i = 1 To UBound(arr)
  6.   If arr(i, 1) <> "" Then
  7.     r = r + 1
  8.     brr(r, 1) = arr(i, 1)
  9.     brr(r, 2) = arr(i, 2)
  10.   End If
  11.   If brr(r, 3) < arr(i, 3) Then brr(r, 3) = arr(i, 3)
  12. Next i
  13. Sheets(2).[a2].Resize(r, 3) = brr
  14. End Sub
复制代码

提取最后一次出现时间.rar

9.01 KB, 下载次数: 12

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-5-9 14:04 | 显示全部楼层    本楼为最佳答案   
  1. Sub aaa()
  2. Dim arr, i&, brr, r&
  3. arr = Sheets(1).Range("a2:c" & Sheets(1).[b65536].End(3).Row)
  4. ReDim brr(1 To UBound(arr), 1 To 3)
  5. For i = 1 To UBound(arr)
  6.   If arr(i, 1) <> "" Then
  7.     r = r + 1
  8.     brr(r, 1) = arr(i, 1)
  9.     brr(r, 2) = arr(i, 2)
  10.   End If
  11.   If brr(r, 3) < arr(i, 3) Then brr(r, 3) = arr(i, 3)
  12. Next i
  13. Sheets(2).[a2].Resize(r, 3) = brr
  14. End Sub
复制代码
回复

使用道具 举报

发表于 2017-5-9 14:09 | 显示全部楼层
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     arr = Sheets("原始数据").[a1].CurrentRegion
  4.     For i = 2 To UBound(arr)
  5.         If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
  6.         x = arr(i, 1): t = CDate(arr(i, 2) & " " & CDate(arr(i, 3)))
  7.         If d(x) < t Then d(x) = t
  8.     Next
  9.     dk = d.keys
  10.     ReDim brr(1 To d.Count, 1 To 3)
  11.     For Each x In d.keys
  12.         n = n + 1
  13.         brr(n, 1) = x
  14.         brr(n, 2) = DateValue(d(x))
  15.         brr(n, 3) = TimeValue(d(x))
  16.     Next
  17.     [a2].Resize(d.Count, 3) = brr
  18. End Sub
复制代码

提取最后一次出现时间.rar

17.72 KB, 下载次数: 7

回复

使用道具 举报

发表于 2017-10-19 09:07 | 显示全部楼层
Sub 练习() '雄鹰2017.10.19
Dim arr, brr, ar, br, cr
Set d = CreateObject("scripting.dictionary")
arr = Sheets("原始数据").[a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
For i = 2 To UBound(arr)
     If VBA.IsNumeric(arr(i, 3)) Then x = Format(arr(i, 3), "hh:mm:ss") Else x = arr(i, 3)
     x = Format(arr(i, 2) & " " & x, "0.000000") '注意精度
     If arr(i, 1) <> "" Then
        d(arr(i, 1)) = x
     Else
        arr(i, 1) = arr(i - 1, 1)
        d(arr(i - 1, 1)) = d(arr(i - 1, 1)) & "," & x
     End If
Next i
For Each k In d.keys
     ar = Split(d(k), ",")
     ReDim br(0 To UBound(ar))
     For i = 0 To UBound(ar)
         br(i) = CDbl(ar(i))
     Next i
     y = Application.Max(br)
     cr = Split(CDate(y), " ")
     n = n + 1
     brr(n, 1) = k
     brr(n, 2) = cr(0)
     brr(n, 3) = cr(1)
Next k
Sheets("结果").[a15].Resize(n, 3) = brr
End Sub
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 04:11 , Processed in 0.405232 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表