打卡记录

SCWYZJ

求助：请教老师！怎样用vba代码实现一键把打卡记录转换成附件所示,加上注解更好！（祥见附件）谢谢！

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, max, i, j, m, n
  arr = [a1].CurrentRegion.Offset(1)
  ReDim brr(1 To UBound(arr, 1) - 1, 1 To 20)
  m = 1: n = 3
  For i = 1 To UBound(arr, 1) - 1
    n = n + 1: brr(m, n) = arr(i, 4)
    If arr(i, 3) <> arr(i + 1, 3) Then
      If max < n Then max = n
      For j = 1 To 3: brr(m, j) = arr(i, j): Next
      m = m + 1: n = 3
    End If
  Next
  With [f2]
    .Resize(Rows.Count - 1, max + 1).ClearContents
    .Resize(m - 1, max) = brr
  End With
End Sub

719404338

1. Sub t()
   
2. Dim d, i%, j%
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. For i = 2 To 19
   
5. d(Range("b" & i).Value & "," & Range("c" & i).Value) = d(Range("b" & i).Value & "," & Range("c" & i).Value) & "," & Range("d" & i)
   
6. Next
   
7. arr = d.keys
   
8. brr = d.items
   
9. For i = 2 To 6
   
10. For j = 7 To 8
    
11. Cells(i, j) = Split(arr(i - 2), ",")(j - 7)
    
12. Next j
    
13. For j = 1 To UBound(Split(brr(i - 2), ","))
    
14. Cells(i, j + 8) = Split(brr(i - 2), ",")(j)
    
15. Next j
    
16. Next i
    
17. End Sub
    

复制代码

SCWYZJ

719404338 发表于 2018-9-29 10:38

719404338老师：谢谢你的帮助！你的代码虽然也行，但不能带出序号，不是我想要的。所以不能送你鲜花！再次感谢你的帮助！

lsc900707

SCWYZJ 发表于 2018-10-1 09:55
719404338老师：谢谢你的帮助！你的代码虽然也行，但不能带出序号，不是我想要的。所以不能送你鲜花！再 ...

你的“鲜花'太金贵了，呵呵。