请教：指纹考勤机导出的数据（EXCEL格式）如何转换成我需要的格式？提前感谢了！

boey宝

真心的不会用宏

gbs7599

840205910 发表于 2012-7-27 11:16
代码没错，是你的资料中有人一天打卡5、6次，而你原来要求一天最多4次，我代码中设置最多4次，当然异常！
...

我也用了，太好用了，虽然我不会做函数，但是很适用呀

LYY12

840205910 发表于 2012-7-26 09:42
应该用字典加数组可以做的，回头再来

指纹考勤数据怎么转换为我想要的数据。谢谢。

乐宝宝0804

mjzxlmg 发表于 2012-8-4 09:29

请教如何做相反的格式转换，图二格式转换成图一？万分感谢

mjzxlmg

LYY12 发表于 2015-8-29 16:33
指纹考勤数据怎么转换为我想要的数据。谢谢。

1. Sub 转置()
   
2.     Dim arr, brr(), i&, maxcolumn&, k&, m&, dic As Object, s, temp() As Integer
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     With Sheet2
   
6.         arr = .Range("A1").CurrentRegion
   
7.         ReDim brr(1 To UBound(arr), 1 To 256)
   
8.         ReDim temp(1 To UBound(arr))
   
9.         For k = 1 To 3
   
10.             brr(1, k) = arr(1, k)
    
11.         Next
    
12.         m = 1
    
13.         For i = 2 To UBound(arr)
    
14.             s = dic(arr(i, 1) & arr(i, 2) & arr(i, 3))
    
15.             If s = Empty Then
    
16.                 m = m + 1
    
17.                 dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) = m
    
18.                 s = m
    
19.                 temp(s) = 3
    
20.                 For k = 1 To 3
    
21.                     brr(s, k) = arr(i, k)
    
22.                 Next
    
23.             End If
    
24.             temp(s) = temp(s) + 1
    
25.             brr(s, temp(s)) = arr(i, 4)
    
26.             If temp(s) > maxcolumn Then
    
27.                 maxcolumn = temp(s)
    
28.                 brr(1, maxcolumn) = "时间" & temp(s) - 3
    
29.             End If
    
30.         Next
    
31.         .[g1].CurrentRegion.Clear
    
32.         .[i2].Resize(m - 1, 1).NumberFormatLocal = "yyyy/m/d"
    
33.         .[j2].Resize(m - 1, maxcolumn - 3).NumberFormatLocal = "[$-x-systime]h:mm:ss AM/PM"
    
34.         With .[g1].Resize(m, maxcolumn)
    
35.             .Value = brr
    
36.             '.Sort key1:=Cells(1, 7), order1:=1, Header:=1  '按工号升序排序
    
37.             .Borders.LineStyle = 1
    
38.             .HorizontalAlignment = xlCenter
    
39.             .VerticalAlignment = xlCenter
    
40.             .Columns.AutoFit
    
41.         End With
    
42.      End With
    
43.      Application.ScreenUpdating = True
    
44. End Sub
    

复制代码

mjzxlmg

乐宝宝0804 发表于 2017-8-21 13:05
请教如何做相反的格式转换，图二格式转换成图一？万分感谢

1. Sub mjzxlmg()
   
2.     Dim arr, brr, i&, j&, m&
   
3.     arr = Sheet2.[g1].CurrentRegion.Value
   
4.     ReDim brr(1 To UBound(arr) * (UBound(arr, 2) - 3), 1 To 4)
   
5.     For i = 1 To 3
   
6.         brr(1, i) = arr(1, i)
   
7.     Next
   
8.     brr(1, 4) = "时间"
   
9.     m = 1
   
10.     For i = 2 To UBound(arr)
    
11.         For j = 4 To UBound(arr, 2)
    
12.             If Len(arr(i, j)) Then
    
13.                 m = m + 1
    
14.                 brr(m, 1) = arr(i, 1)
    
15.                 brr(m, 2) = arr(i, 2)
    
16.                 brr(m, 3) = arr(i, 3)
    
17.                 brr(m, 4) = arr(i, j)
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     If m > 1 Then
    
22.         Application.ScreenUpdating = False
    
23.         With Sheet2
    
24.             .[x1].CurrentRegion.Value = Empty
    
25.             .[z2].Resize(m - 1, 1).NumberFormatLocal = "yyyy/m/d"
    
26.             .[aa2].Resize(m - 1, 1).NumberFormatLocal = "[$-x-systime]h:mm:ss AM/PM"
    
27.             With .[x1].Resize(m, 4)
    
28.                 .Value = brr
    
29.                 .Borders.LineStyle = 1
    
30.                 .HorizontalAlignment = xlCenter
    
31.                 .VerticalAlignment = xlCenter
    
32.                 .Columns.AutoFit
    
33.             End With
    
34.         End With
    
35.         Application.ScreenUpdating = True
    
36.     End If
    
37. End Sub
    

复制代码

mjzxlmg

上两楼代码的测试附件：

乐宝宝0804

mjzxlmg 发表于 2017-8-21 20:51
上两楼代码的测试附件：

楼上的大神，我表达有误，麻烦能帮我看看附件的表格如何转换格式吗？刚接手考勤，急啊，附件我下一楼上传，万分感谢

乐宝宝0804

卡式报表（格式转换） - 副本.rar (35.47 KB, 下载次数: 14)

2017-8-22 11:17 上传

点击文件名下载附件

上传附件，麻烦帮我看看

mjzxlmg

乐宝宝0804 发表于 2017-8-22 10:59
上传附件，麻烦帮我看看

1. Sub mjzxlmg()
   
2.     Dim arr, brr, i&, j&, k&, m&
   
3.     arr = Sheet2.[b1].CurrentRegion.Value
   
4.     ReDim brr(1 To UBound(arr) * 2, 1 To UBound(arr, 2) - 1)
   
5.     For i = 1 To UBound(arr, 2) - 2
   
6.         brr(1, i) = arr(1, i)
   
7.     Next
   
8.     brr(1, UBound(arr, 2) - 1) = "上下班时间"
   
9.     m = 1
   
10.     For i = 2 To UBound(arr)
    
11.         For j = UBound(arr, 2) - 1 To UBound(arr, 2)
    
12.             m = m + 1
    
13.             brr(m, UBound(arr, 2) - 1) = arr(i, j)
    
14.             For k = 1 To UBound(arr, 2) - 2
    
15.                 brr(m, k) = arr(i, k)
    
16.             Next
    
17.         Next
    
18.     Next
    
19.     If m > 1 Then
    
20.         Application.ScreenUpdating = False
    
21.         With Sheet2
    
22.             .[j1].CurrentRegion.Clear
    
23.             .[k2].Resize(m - 1).NumberFormatLocal = "m""月""d""日"";@"
    
24.             .[l2].Resize(m - 1).NumberFormatLocal = "h:mm;@"
    
25.             With [j1].Resize(m, UBound(arr, 2) - 1)
    
26.                 .Value = brr
    
27.                 .Borders.LineStyle = 1
    
28.                 .HorizontalAlignment = 3
    
29.                 .VerticalAlignment = 2
    
30.                 .Columns.AutoFit
    
31.             End With
    
32.         End With
    
33.         Application.ScreenUpdating = True
    
34.     End If
    
35. End Sub

复制代码