[已解决]请高手们帮忙看下这个能否用vba实现的功能，谢谢高手师傅们的帮忙

qiongmei

我附件上有2表，我希望得到一个vba代码，当我执行的时候，他根据分类表格中同一个人，同一天的考勤放在汇总表格同一行里，现在的汇总表格就是我希望得到的结果，谢谢高手师傅们的帮忙

最佳答案

月排行榜 / 总排行榜

xdragon

2015-5-10 17:21

1. Sub Ttl()
   
2.     Dim arr
   
3.     Dim re()
   
4.     Dim d As Object, i As Long, j As Long, KeyString As String, Cnt As Long
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheets("分类").Range("A1:E" & Sheets("分类").Cells(Rows.Count, 1).End(xlUp).Row).Value
   
7.     ReDim re(1 To UBound(arr), 1 To 5)
   
8.     For i = 1 To UBound(arr)
   
9.         KeyString = arr(i, 1) & arr(i, 2) & arr(i, 4)
   
10.         If Not d.exists(KeyString) Then
    
11.             Cnt = Cnt + 1
    
12.             d(KeyString) = Array(Cnt, 5)
    
13.             For j = 1 To 4
    
14.                 re(Cnt, j) = arr(i, j)
    
15.             Next
    
16.         Else
    
17.             d(KeyString) = Array(d(KeyString)(0), d(KeyString)(1) + 1)
    
18.             If UBound(re, 2) < d(KeyString)(1) Then ReDim Preserve re(1 To UBound(re), 1 To UBound(re, 2) + 1)
    
19.         End If
    
20.         re(d(KeyString)(0), d(KeyString)(1)) = arr(i, 5)
    
21.     Next
    
22.     With Sheets("汇总").Range("A1").Resize(Cnt, UBound(re, 2))
    
23.         .Value = re
    
24.         .Offset(, 4).NumberFormatLocal = "h:mm;@"
    
25.     End With
    
26. End Sub

复制代码

跳转到最佳答案楼层

xdragon

1. Sub Ttl()
   
2.     Dim arr
   
3.     Dim re()
   
4.     Dim d As Object, i As Long, j As Long, KeyString As String, Cnt As Long
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheets("分类").Range("A1:E" & Sheets("分类").Cells(Rows.Count, 1).End(xlUp).Row).Value
   
7.     ReDim re(1 To UBound(arr), 1 To 5)
   
8.     For i = 1 To UBound(arr)
   
9.         KeyString = arr(i, 1) & arr(i, 2) & arr(i, 4)
   
10.         If Not d.exists(KeyString) Then
    
11.             Cnt = Cnt + 1
    
12.             d(KeyString) = Array(Cnt, 5)
    
13.             For j = 1 To 4
    
14.                 re(Cnt, j) = arr(i, j)
    
15.             Next
    
16.         Else
    
17.             d(KeyString) = Array(d(KeyString)(0), d(KeyString)(1) + 1)
    
18.             If UBound(re, 2) < d(KeyString)(1) Then ReDim Preserve re(1 To UBound(re), 1 To UBound(re, 2) + 1)
    
19.         End If
    
20.         re(d(KeyString)(0), d(KeyString)(1)) = arr(i, 5)
    
21.     Next
    
22.     With Sheets("汇总").Range("A1").Resize(Cnt, UBound(re, 2))
    
23.         .Value = re
    
24.         .Offset(, 4).NumberFormatLocal = "h:mm;@"
    
25.     End With
    
26. End Sub

复制代码

xdragon

附件哈

qh8600

Book1.rar (10.77 KB, 下载次数: 9)

2015-5-10 17:43 上传

点击文件名下载附件
我也写了一个{:112:}

lyjlyg06

都是高手的回答！

qiongmei

谢谢这么多高手师傅的帮忙，万分感谢，您们提供的代码正是我所希望的