设为首页收藏本站
简字体切换切换到宽版
1234

ExcelHome技术论坛

用户名  找回密码
 免费注册

QQ登录

只需一步，快速开始

快捷登录

帖子
ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › 如何将时间差大于40分钟胡数组分为两个dictionary？
EH技术汇-专业的职场技能充电站 妙哉！函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器，一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理，一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
返回列表 发新帖
查看: 102|回复: 2

如何将时间差大于40分钟胡数组分为两个dictionary？

[复制链接]
ning84

TA的精华主题

TA的得分主题
发表于 2025-3-26 21:18 | 显示全部楼层 |阅读模式
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★


Arr(28) = "2025/3/26 9:06:24"
Arr(29) = "2025/3/26 9:48:20"

相差40多分钟，重新生成多个ictionary。




  1. Sub a1()
  2.   Dim Arr(47)

  4.     Arr(0) = "2025/3/26 8:00:44"
  5.     Arr(1) = "2025/3/26 8:05:22"
  6.     Arr(2) = "2025/3/26 8:06:22"
  7.     Arr(3) = "2025/3/26 8:09:08"
  8.     Arr(4) = "2025/3/26 8:11:08"
  9.     Arr(5) = "2025/3/26 8:13:20"
  10.     Arr(6) = "2025/3/26 8:18:00"
  11.     Arr(7) = "2025/3/26 8:19:44"
  12.     Arr(8) = "2025/3/26 8:19:46"
  13.     Arr(9) = "2025/3/26 8:23:14"
  14.     Arr(10) = "2025/3/26 8:26:12"
  15.     Arr(11) = "2025/3/26 8:26:30"
  16.     Arr(12) = "2025/3/26 8:28:12"
  17.     Arr(13) = "2025/3/26 8:30:28"
  18.     Arr(14) = "2025/3/26 8:30:42"
  19.     Arr(15) = "2025/3/26 8:36:20"
  20.     Arr(16) = "2025/3/26 8:37:56"
  21.     Arr(17) = "2025/3/26 8:40:00"
  22.     Arr(18) = "2025/3/26 8:43:50"
  23.     Arr(19) = "2025/3/26 8:46:26"
  24.     Arr(20) = "2025/3/26 8:47:28"
  25.     Arr(21) = "2025/3/26 8:48:40"
  26.     Arr(22) = "2025/3/26 8:50:40"
  27.     Arr(23) = "2025/3/26 8:51:36"
  28.     Arr(24) = "2025/3/26 8:54:44"
  29.     Arr(25) = "2025/3/26 8:55:50"
  30.     Arr(26) = "2025/3/26 8:58:12"
  31.     Arr(27) = "2025/3/26 9:03:32"
  32.     Arr(28) = "2025/3/26 9:06:24"
  33.     Arr(29) = "2025/3/26 9:48:20"
  34.     Arr(30) = "2025/3/26 9:49:20"
  35.     Arr(31) = "2025/3/26 9:50:18"
  36.     Arr(32) = "2025/3/26 9:51:24"
  37.     Arr(33) = "2025/3/26 9:53:26"
  38.     Arr(34) = "2025/3/26 9:54:48"
  39.     Arr(35) = "2025/3/26 9:55:56"
  40.     Arr(36) = "2025/3/26 9:56:42"
  41.     Arr(37) = "2025/3/26 9:57:58"
  42.     Arr(38) = "2025/3/26 9:58:56"
  43.     Arr(39) = "2025/3/26 10:00:10"
  44.     Arr(40) = "2025/3/26 10:00:42"
  45.     Arr(41) = "2025/3/26 10:01:50"
  46.     Arr(42) = "2025/3/26 10:02:58"
  47.     Arr(43) = "2025/3/26 10:04:30"
  48.     Arr(44) = "2025/3/26 10:04:52"
  49.     Arr(45) = "2025/3/26 10:06:12"
  50.     Arr(46) = "2025/3/26 10:06:22"
  51.     Arr(47) = "2025/3/26 10:07:22"
  52.   Dim PptDict As Scripting.Dictionary, TotalDict As Scripting.Dictionary
  53.       Set PptDict = New Scripting.Dictionary
  54.       Set TotalDict = New Scripting.Dictionary
  55.       Dim oDate1 As Date, oDate2 As Date

  57.          
  58.           For ii = 0 To 46 '.Count - 1
  59.               PptDict(Arr(ii)) = Arr(ii)
  60.               oDate1 = Arr(ii)
  61.               oDate2 = Arr(ii + 1)
  62.               If Abs(DateDiff("s", oDate1, oDate2)) >= 40 * 60 Then
  63.                   Set TotalDict(PptDict) = Nothing
  64.                   Set PptDict = New Scripting.Dictionary
  65.               End If
  66.               
  67.           Next ii
  68.           Set TotalDict(PptDict) = Nothing
  69.    
  70.           For ii = 0 To TotalDict.Count - 1 '
  71.               Set PptDict = TotalDict.Keys(ii)
  72.               Debug.Print "Array(" & ii + 1&; ")"
  73.               For jj = 0 To PptDict.Count - 1
  74.                   Debug.Print PptDict.Keys(jj)
  75.               Next jj
  76.               
  77.          
  78.           Next ii
  79.   
  80. End Sub
复制代码


回复

举报

ning84

TA的精华主题

TA的得分主题
 楼主| 发表于 2025-3-26 21:36 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
你的代码逻辑有一些问题，特别是在处理 `TotalDict` 和 `PptDict` 的部分。以下是对代码的优化和修正：

1. **数组初始化问题**：`Arr(47)` 超出了数组的实际范围（0 到 46），应该调整为 `Arr(46)`。
2. **`TotalDict` 的使用问题**：`TotalDict` 应该存储分组后的字典对象，而不是直接将 `PptDict` 存储进去。
3. **循环逻辑问题**：在计算时间差时，需要确保不会超出数组范围。
4. **`Debug.Print` 的问题**：`Debug.Print` 中的语法错误需要修正。

以下是优化后的代码：

```vba
Sub a1()
    Dim Arr(46) As String

    Arr(0) = "2025/3/26 8:00:44"
    Arr(1) = "2025/3/26 8:05:22"
    Arr(2) = "2025/3/26 8:06:22"
    Arr(3) = "2025/3/26 8:09:08"
    Arr(4) = "2025/3/26 8:11:08"
    Arr(5) = "2025/3/26 8:13:20"
    Arr(6) = "2025/3/26 8:18:00"
    Arr(7) = "2025/3/26 8:19:44"
    Arr(8) = "2025/3/26 8:19:46"
    Arr(9) = "2025/3/26 8:23:14"
    Arr(10) = "2025/3/26 8:26:12"
    Arr(11) = "2025/3/26 8:26:30"
    Arr(12) = "2025/3/26 8:28:12"
    Arr(13) = "2025/3/26 8:30:28"
    Arr(14) = "2025/3/26 8:30:42"
    Arr(15) = "2025/3/26 8:36:20"
    Arr(16) = "2025/3/26 8:37:56"
    Arr(17) = "2025/3/26 8:40:00"
    Arr(18) = "2025/3/26 8:43:50"
    Arr(19) = "2025/3/26 8:46:26"
    Arr(20) = "2025/3/26 8:47:28"
    Arr(21) = "2025/3/26 8:48:40"
    Arr(22) = "2025/3/26 8:50:40"
    Arr(23) = "2025/3/26 8:51:36"
    Arr(24) = "2025/3/26 8:54:44"
    Arr(25) = "2025/3/26 8:55:50"
    Arr(26) = "2025/3/26 8:58:12"
    Arr(27) = "2025/3/26 9:03:32"
    Arr(28) = "2025/3/26 9:06:24"
    Arr(29) = "2025/3/26 9:48:20"
    Arr(30) = "2025/3/26 9:49:20"
    Arr(31) = "2025/3/26 9:50:18"
    Arr(32) = "2025/3/26 9:51:24"
    Arr(33) = "2025/3/26 9:53:26"
    Arr(34) = "2025/3/26 9:54:48"
    Arr(35) = "2025/3/26 9:55:56"
    Arr(36) = "2025/3/26 9:56:42"
    Arr(37) = "2025/3/26 9:57:58"
    Arr(38) = "2025/3/26 9:58:56"
    Arr(39) = "2025/3/26 10:00:10"
    Arr(40) = "2025/3/26 10:00:42"
    Arr(41) = "2025/3/26 10:01:50"
    Arr(42) = "2025/3/26 10:02:58"
    Arr(43) = "2025/3/26 10:04:30"
    Arr(44) = "2025/3/26 10:04:52"
    Arr(45) = "2025/3/26 10:06:12"
    Arr(46) = "2025/3/26 10:06:22"

    Dim PptDict As Scripting.Dictionary, TotalDict As Scripting.Dictionary
    Set PptDict = New Scripting.Dictionary
    Set TotalDict = New Scripting.Dictionary
    Dim oDate1 As Date, oDate2 As Date
    Dim ii As Integer, jj As Integer
    Dim groupCounter As Integer

    groupCounter = 1
    For ii = 0 To 45 ' 避免超出数组范围
        PptDict(Arr(ii)) = Arr(ii)
        oDate1 = Arr(ii)
        oDate2 = Arr(ii + 1)
        If Abs(DateDiff("s", oDate1, oDate2)) >= 40 * 60 Then
            TotalDict.Add groupCounter, PptDict
            Set PptDict = New Scripting.Dictionary
            groupCounter = groupCounter + 1
        End If
    Next ii
    ' 添加最后一个分组
    If PptDict.Count > 0 Then
        TotalDict.Add groupCounter, PptDict
    End If

    ' 输出结果
    For ii = 1 To TotalDict.Count
        Set PptDict = TotalDict(ii)
        Debug.Print "Group(" & ii & "):"
        For jj = 0 To PptDict.Count - 1
            Debug.Print PptDict.Keys(jj)
        Next jj
    Next ii
End Sub
```

### 优化点说明：
1. **数组范围调整**：将 `Arr(47)` 改为 `Arr(46)`，确保数组范围正确。
2. **分组逻辑修正**：使用 `TotalDict` 存储分组后的字典对象，每个分组对应一个 `PptDict`。
3. **时间差计算**：在循环中避免超出数组范围。
4. **输出修正**：修正了 `Debug.Print` 的语法错误，并按照分组输出结果。

### 输出示例：
运行此代码后，`Debug.Print` 将按分组输出时间数组的内容。
回复

举报

ning84

TA的精华主题

TA的得分主题
 楼主| 发表于 2025-3-27 11:37 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
Learn ,Learn

  1. Sub DFSAFD()
  2.   Dim Arr(47)

  4.     Arr(0) = "2025/3/26 8:00:44"
  5.     Arr(1) = "2025/3/26 8:05:22"
  6.     Arr(2) = "2025/3/26 8:06:22"
  7.     Arr(3) = "2025/3/26 8:09:08"
  8.     Arr(4) = "2025/3/26 8:11:08"
  9.     Arr(5) = "2025/3/26 8:13:20"
  10.     Arr(6) = "2025/3/26 8:18:00"
  11.     Arr(7) = "2025/3/26 8:19:44"
  12.     Arr(8) = "2025/3/26 8:19:46"
  13.     Arr(9) = "2025/3/26 8:23:14"
  14.     Arr(10) = "2025/3/26 8:26:12"
  15.     Arr(11) = "2025/3/26 8:26:30"
  16.     Arr(12) = "2025/3/26 8:28:12"
  17.     Arr(13) = "2025/3/26 8:30:28"
  18.     Arr(14) = "2025/3/26 8:30:42"
  19.     Arr(15) = "2025/3/26 8:36:20"
  20.     Arr(16) = "2025/3/26 8:37:56"
  21.     Arr(17) = "2025/3/26 8:40:00"
  22.     Arr(18) = "2025/3/26 8:43:50"
  23.     Arr(19) = "2025/3/26 8:46:26"
  24.     Arr(20) = "2025/3/26 8:47:28"
  25.     Arr(21) = "2025/3/26 8:48:40"
  26.     Arr(22) = "2025/3/26 8:50:40"
  27.     Arr(23) = "2025/3/26 8:51:36"
  28.     Arr(24) = "2025/3/26 8:54:44"
  29.     Arr(25) = "2025/3/26 8:55:50"
  30.     Arr(26) = "2025/3/26 8:58:12"
  31.     Arr(27) = "2025/3/26 9:03:32"
  32.     Arr(28) = "2025/3/26 9:06:24"
  33.     Arr(29) = "2025/3/26 9:48:20"
  34.     Arr(30) = "2025/3/26 9:49:20"
  35.     Arr(31) = "2025/3/26 9:50:18"
  36.     Arr(32) = "2025/3/26 9:51:24"
  37.     Arr(33) = "2025/3/26 9:53:26"
  38.     Arr(34) = "2025/3/26 9:54:48"
  39.     Arr(35) = "2025/3/26 9:55:56"
  40.     Arr(36) = "2025/3/26 9:56:42"
  41.     Arr(37) = "2025/3/26 9:57:58"
  42.     Arr(38) = "2025/3/26 9:58:56"
  43.     Arr(39) = "2025/3/26 10:00:10"
  44.     Arr(40) = "2025/3/26 10:00:42"
  45.     Arr(41) = "2025/3/26 10:01:50"
  46.     Arr(42) = "2025/3/26 10:02:58"
  47.     Arr(43) = "2025/3/26 10:04:30"
  48.     Arr(44) = "2025/3/26 10:04:52"
  49.     Arr(45) = "2025/3/26 10:06:12"
  50.     Arr(46) = "2025/3/26 10:06:22"
  51.     Arr(47) = "2025/3/26 10:07:22"
  52.   Dim PptDict As Scripting.Dictionary
  53.     Set PptDict = New Scripting.Dictionary
  54.   Dim PptCollect As Collection, PptColl, pDict As Scripting.Dictionary
  55.   Dim ii, Kk As Integer
  56.     Set PptCollect = GroupTimeArray(Arr, 40 * 60)
  57.    
  58.     For Each pDict In PptCollect
  59.          '''
  60.          Debug.Print "Group " & Kk + 1

  62.          With pDict
  63.                For ii = 0 To .Count - 1
  64.                     Debug.Print .Keys(ii)
  65.                Next ii
  66.          End With
  67.          Kk = Kk + 1
  68.          Debug.Print "***************"
  69.     Next pDict
  70.   
  71. End Sub



  75. Function GroupTimeArray(timeArray As Variant, intervalThreshold As Long) As Collection
  76.     Dim result As Collection
  77.     Set result = New Collection

  79.     Dim PptDict As Scripting.Dictionary
  80.     Set PptDict = New Scripting.Dictionary

  82.     Dim i As Long
  83.     Dim oDate1 As Date, oDate2 As Date

  85.     For i = LBound(timeArray) To UBound(timeArray) - 1
  86.         PptDict(timeArray(i)) = timeArray(i)
  87.         oDate1 = CDate(timeArray(i))
  88.         oDate2 = CDate(timeArray(i + 1))

  90.         If Abs(DateDiff("s", oDate1, oDate2)) >= intervalThreshold Then
  91.             result.Add PptDict
  92.             Set PptDict = New Scripting.Dictionary
  93.         End If
  94.     Next i

  96.     ' 添加最后一个分组
  97.     If PptDict.Count > 0 Then
  98.         PptDict(timeArray(UBound(timeArray))) = timeArray(UBound(timeArray))
  99.         result.Add PptDict
  100.     End If

  102.     Set GroupTimeArray = result
  103. End Function



复制代码
回复

举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

1234

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-4-23 22:45 , Processed in 0.029109 second(s), 9 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！     本站特聘法律顾问：李志群律师

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