附件已修改！是单独表格管自己统计，不是全部汇总，刚刚的附件有误，多了sheet2已....

zopey

名字列 每周的都不同吧，29个人是固定的吗？

lsdongjh

托管考勤登记.rar (77.89 KB, 下载次数: 0)

2018-6-11 16:56 上传

点击文件名下载附件

相关的附件，你自己再放，只放上了这个文件，和要处理的在同一文件夹下即可

zopey

Dim dic As Object, wb As Workbook, filename
Dim arr, brr()
Set dic = CreateObject("Scripting.Dictionary")

filename = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
Do
    If filename = "" Then
       Exit Do
    Else
       '读取文件名
       Worksheets("跟班登记表").Copy after:=Worksheets(Worksheets.Count)
       ActiveSheet.Name = filename
       '获取数据
       Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & filename)
           arr = wb.Sheets(1).Range("b4:f27")
       wb.Close True
       Set wb = Nothing
       '数据分析
       k = 0
       ReDim brr(1 To 29, 0 To 20)
       dic.RemoveAll
       For j = 1 To 5
       For i = 1 To 24
       If arr(i, j) <> "" Then
           If Not dic.exists(arr(i, j)) Then
              k = k + 1
              brr(k, 0) = arr(i, j)
              dic(arr(i, j)) = k
           End If
           If brr(dic(arr(i, j)), (j - 1) * 4 + 1) = 0 Then
              brr(dic(arr(i, j)), (j - 1) * 4 + 1) = 1
           ElseIf brr(dic(arr(i, j)), (j - 1) * 4 + 2) = 0 Then
              brr(dic(arr(i, j)), (j - 1) * 4 + 2) = 1
           ElseIf brr(dic(arr(i, j)), (j - 1) * 4 + 3) = 0 Then
              brr(dic(arr(i, j)), (j - 1) * 4 + 3) = 1
           ElseIf brr(dic(arr(i, j)), (j - 1) * 4 + 4) = 0 Then
              brr(dic(arr(i, j)), (j - 1) * 4 + 4) = 1
           End If
       End If
       Next
       Next
       ActiveSheet.[b4].Resize(29, 21) = brr
    End If
    filename = Dir
Loop

End Sub



考勤登记.zip (98.26 KB, 下载次数: 2)

2018-6-12 09:11 上传

点击文件名下载附件