如何高效率查找匹配汇总

joejinx

要整理考勤记录，自己写了一半的if判断，发现效率非常非常慢，请教高手怎样提高效率，并写完整需求。多谢希望要达成的效果
1、提取“打卡记录”里的 人名及对应考勤号码到“考勤汇总”中


2、根据考勤号码再将“打卡记录”对应日期的第一次打卡记录和当天最后一次打卡记录写入“考勤汇总”

111考勤记录.zip (85.5 KB, 下载次数: 15)

2019-2-2 13:51 上传

点击文件名下载附件

一把小刀闯天下

'当前如果有多次打卡，首次出现按首次打卡来处理，最后一次出现按最后打卡来处理。如果当天刷卡多于一次的计算工时

'试了一下才知道你很多数据都不全，输出单元格格式我就不作处理了，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, m, pos
  arr = Sheets("打卡记录").[a1].CurrentRegion.Offset(1)
  ReDim brr(UBound(arr, 1) / 30 * 3, 1 To 3 + 31)
  brr(0, 1) = "考勤号码": brr(0, 2) = "姓名": brr(0, 3) = "日期"
  For i = 1 To 31: brr(0, i + 3) = i: Next
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 2) <> arr(j + 1, 2) Then
        m = m + 3
        brr(m - 2, 1) = arr(i, 3): brr(m - 2, 2) = arr(i, 2)
        brr(m - 2, 3) = "首次打卡": brr(m - 1, 3) = "最后打卡": brr(m, 3) = "工时"
        For k = i To j
          pos = Val(Format(arr(k, 4), "d"))
          brr(m - 2, pos + 3) = arr(k, 5)
          For kk = k To UBound(arr, 1) - 1
            If arr(kk, 4) <> arr(kk + 1, 4) Then
              If kk > k Then
                brr(m - 1, pos + 3) = arr(kk, 5)
                brr(m, pos + 3) = brr(m - 1, pos + 3) - brr(m - 2, pos + 3)
              End If
              k = kk: Exit For
            End If
        Next kk, k
        i = j: Exit For
      End If
  Next j, i
  Sheets("考勤汇总").[a2].Resize(m + 1, UBound(brr, 2)) = brr
End Sub

一把小刀闯天下

'可能是这样，最后打卡跟工时不作处理，给你凑成示例结果，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, m, pos
  arr = Sheets("打卡记录").[a1].CurrentRegion.Offset(1)
  ReDim brr(UBound(arr, 1) / 30 * 3, 1 To 3 + 31)
  brr(0, 1) = "考勤号码": brr(0, 2) = "姓名": brr(0, 3) = "日期"
  For i = 1 To 31: brr(0, i + 3) = i: Next
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 2) <> arr(j + 1, 2) Then
        m = m + 3
        brr(m - 2, 1) = arr(i, 3): brr(m - 2, 2) = arr(i, 2)
        brr(m - 2, 3) = "首次打卡": brr(m - 1, 3) = "最后打卡": brr(m, 3) = "工时"
        For k = i To j
          pos = Val(Format(arr(k, 4), "d"))
          For kk = k To UBound(arr, 1) - 1
            If arr(kk, 4) <> arr(kk + 1, 4) Then brr(m - 2, pos + 3) = arr(kk, 5): k = kk: Exit For
        Next kk, k
        i = j: Exit For
      End If
  Next j, i
  Sheets("考勤汇总").[a2].Resize(m + 1, UBound(brr, 2)) = brr
End Sub

joejinx

一把小刀闯天下 发表于 2019-2-2 14:48
'当前如果有多次打卡，首次出现按首次打卡来处理，最后一次出现按最后打卡来处理。如果当天刷卡多于一次的 ...

感谢，果然是大神。看来我还得仔细学一下字典的用法

一把小刀闯天下

joejinx 发表于 2019-2-2 14:58
感谢，果然是大神。看来我还得仔细学一下字典的用法

哈哈哈，你哪只眼睛看到我用了字典，笑死！

yaozong

1. Sub zzz()
   
2. Sheet2.Activate
   
3. Application.ScreenUpdating = False
   
4. ActiveSheet.UsedRange.ClearContents
   
5. Dim d, ds, dz, arr, i&, j&, k&, m&, n&
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Set ds = CreateObject("Scripting.Dictionary")
   
8. Set dz = CreateObject("Scripting.Dictionary")
   
9. arr = Sheet1.[a1].CurrentRegion.Value
   
10. n = UBound(arr) * 2
    
11. ReDim brr(1 To n * 2, 1 To 34)
    
12. brr(1, 1) = "考勤号码": brr(1, 2) = "姓名": brr(1, 3) = "项目\日期"
    
13. For j = 1 To 31
    
14.   brr(1, j + 3) = j
    
15. Next
    
16. m = 1
    
17. For i = 2 To UBound(arr)
    
18.   n = Day(arr(i, 4))
    
19.   s = arr(i, 2) & arr(i, 3)
    
20.   s2 = arr(i, 2) & arr(i, 3) & n
    
21.   dz(s2) = arr(i, 5)
    
22.   If Not d.exists(s) Then
    
23.     m = m + 1
    
24.     d(s) = m
    
25.     brr(m, 1) = arr(i, 3)
    
26.     brr(m, 2) = arr(i, 2)
    
27.     brr(m, 3) = "首次打卡"
    
28.     brr(m + 1, 3) = "末次打卡"
    
29.     brr(m + 2, 3) = "工时"
    
30.     m = m + 2
    
31.   End If
    
32. Next
    
33. For i = UBound(arr) To 2 Step -1
    
34.   n = Day(arr(i, 4))
    
35.   s2 = arr(i, 2) & arr(i, 3) & n
    
36.   ds(s2) = arr(i, 5)
    
37. Next
    
38. For i = 2 To m Step 3
    
39.   For j = 4 To 34
    
40.     s = brr(i, 2) & brr(i, 1) & brr(1, j)
    
41.     brr(i, j) = ds(s)
    
42.     brr(i + 1, j) = dz(s)
    
43.     If brr(i + 1, j) >= brr(i, j) Then
    
44.       brr(i + 2, j) = brr(i + 1, j) - brr(i, j)
    
45.     Else
    
46.       brr(i + 2, j) = 0
    
47.     End If
    
48.   Next
    
49. Next
    
50. [a2].Resize(m, 34) = brr
    
51. Application.ScreenUpdating = True
    
52. End Sub

复制代码

yaozong

参考附件。。。。。。

micch

打卡很麻烦的，如果一个人同一天打卡多次，但都是上班打卡，没有一次下班打卡。首次打卡后最后一次打卡记录下来也和实际应用不搭边。而且工时总得有个计算规则，总不能最后打卡-首次打卡吧，那可能两次打卡间隔几秒钟，因为没有下班打卡嘛，没有规则那只能空着了。

joejinx

一把小刀闯天下 发表于 2019-2-2 15:01
哈哈哈，你哪只眼睛看到我用了字典，笑死！

哈哈，我是小白啊，感觉你写的这个跟字典很像 就以为是字典咯