用字典没有实现考勤的稽核多表查询功能

吴明锋5065

Sub 生成考勤异常数据()

Dim 棋盘(1 To 100000, 1 To 19)
Dim 行数
Dim arr, arr1, x As Long, sr As String, k As Long, J
' k = 0
Application.ScreenUpdating = False
On Error Resume Next
   If Sheets("生成报表").Range("A1048576").End(xlUp).Row > 7 Then
    Sheets("生成报表").Range("A7:S1048576").Clear   '清除原有数据，但保留表头
   End If

   Set D = CreateObject("SCRIPTING.DICTIONARY")
      arr = Sheets("原始数据").Range("A2:M" & Sheets("原始数据").Range("B1048576").End(xlUp).Row) '从原始数据表中取数据

              For x = 2 To UBound(arr)

                    If arr(x, 5) > Sheets("生成报表").Range("B1") And arr(x, 7) = 1 And arr(x - 1, 7) = 2 And arr(x - 1, 5) > Sheets("生成报表").Range("D1") Then

                    sr = arr(x, 2) & "-" & arr(x, 4)
'sr = arr(x, 2)
                                  k = k + 1

                                  棋盘(k, 1) = arr(x - 1, 2) '取人员
                                  棋盘(k, 2) = arr(x - 1, 4) '取日期
                                  棋盘(k, 3) = arr(x - 1, 5) '取刷出时间

                                  棋盘(k, 4) = arr(x - 1, 7) '取门禁标识
                                  棋盘(k, 5) = arr(x - 1, 9) '取ID号
                                  棋盘(k, 6) = arr(x, 5)  '取刷入时间

                                  棋盘(k, 7) = arr(x, 7)   '取门禁标识
                                  棋盘(k, 8) = arr(x, 9)   '取ID号

                                  棋盘(k, 9) = Abs(DateDiff("n", 棋盘(k, 6), 棋盘(k, 3)))
'
'                                        If 棋盘(k, 9) > Sheets("生成报表").Range("B2") Then     '进行时间间隔判断
'                                            k = k
'                                          Else: k = k - 1
'                                        End If

'                        End If
                               ElseIf arr(x, 5) > Sheets("生成报表").Range("B1") And arr(x, 6) = 3 And arr(x, 2) = 棋盘(k, 1) And arr(x, 4) = 棋盘(k, 2) Then

                           棋盘(k, 10) = arr(x, 2)
                           棋盘(k, 11) = arr(x, 4)
                           棋盘(k, 12) = arr(x, 5)
                           棋盘(k, 13) = Abs(DateDiff("n", 棋盘(k, 12), 棋盘(k, 6)))
                               End If
                           棋盘(k, 18) = sr

               Next x


       arr1 = Sheets("星航门禁记录").Range("A2:M" & Sheets("星航门禁记录").Range("B1048576").End(xlUp).Row) '从星航门禁记录中取数据
           For x = 1 To UBound(arr1)
           sr = arr1(x, 2) & "-" & arr1(x, 12)

           If D.Exists(sr) Then
           MsgBox D(sr) & x


                                  行数 = D(sr)
                                  棋盘(行数, 14) = arr1(x, 1)
                                  棋盘(行数, 15) = arr1(x, 2)
                                  棋盘(行数, 16) = arr1(x, 12)
                                  棋盘(行数, 17) = arr1(x, 13)
                                  棋盘(行数, 19) = sr
'                                End If
'                               Else
'                                  k = k + 1
'                                   D(sr) = k
'                                  棋盘(k, 14) = arr1(x, 1)
'                                  棋盘(k, 15) = arr1(x, 2)
'                                  棋盘(k, 16) = arr1(x, 12)
'                                  棋盘(k, 17) = arr1(x, 13)
'                                  棋盘(k, 19) = sr
                            End If

               Next x

Sheets("生成报表").Range("A7").Resize(k + 1, 19) = 棋盘
Sheets("生成报表").Range("C7:C65536").NumberFormatLocal = "[$-x-systime]h:mm:ss AM/PM"
  Sheets("生成报表").Range("F7:F65536").NumberFormatLocal = "[$-x-systime]h:mm:ss AM/PM"
    Sheets("生成报表").Range("L7:L65536").NumberFormatLocal = "[$-x-systime]h:mm:ss AM/PM"

End Sub

吴明锋5065

各位大佬：帮忙看一下这个功能为何没有实现，我想将星航门禁记录表中与原始数据表中同一个人同一天有记录的人员在生成报表工作表中在同一行显示 出来，但是结果 出不来，哪位大佬帮忙修改一下，谢谢

吴明锋5065

问题点应该是出现在了这里，对应的找不到已经存在的SR,但是实际是存在的，不知道是什么原因找不到
请大神们帮忙看一下
arr1 = Sheets("星航门禁记录").Range("A2:M" & Sheets("星航门禁记录").Range("B1048576").End(xlUp).Row) '从星航门禁记录中取数据
           For x = 1 To UBound(arr1)
           sr = arr1(x, 2) & "-" & arr1(x, 12)

           If D.Exists(sr) Then
           MsgBox D(sr) & x


                                  行数 = D(sr)
                                  棋盘(行数, 14) = arr1(x, 1)
                                  棋盘(行数, 15) = arr1(x, 2)
                                  棋盘(行数, 16) = arr1(x, 12)
                                  棋盘(行数, 17) = arr1(x, 13)
                                  棋盘(行数, 19) = sr

zpy2

附件里是乱码，打不开