据日期判断，转置姓名

tengyt

据日期判断，转置姓名，谢谢老师

不知道为什么

                                   

tengyt

不知道为什么 发表于 2018-10-8 22:03

Sub test()
    Dim arr, Dic, r&, i&
    Set Dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    With Sheets("缺勤")
        r = .Cells(.Rows.Count, 2).End(3).Row
        arr = .Range("b3:e" & r)
        For i = 1 To UBound(arr)
            Dic(DateValue(arr(i, 1))) = Dic(DateValue(arr(i, 1))) & " " & arr(i, 4)
        Next i
    End With
    With Sheets("缺勤转置")
        .Range("a3:b999").ClearContents
        .Range("a3").Resize(Dic.Count, 2) = Application.Transpose(Array(Dic.keys, Dic.items))
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
End Sub
谢谢老师，太强大了

tengyt

还有一个问题是：
反过来，据姓名判断，转置日期
老师帮忙改改代码，谢谢老师谢谢老师

tengyt

不知道为什么 发表于 2018-10-8 22:03

先谢谢老师，代码完美解决上面问题了

还有一个问题是：
反过来，据姓名判断，转置日期
老师帮忙改改代码，谢谢老师谢谢老师

Sub 一线缺勤转置()
    Dim arr, Dic, r&, i&
    Set Dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    With Sheets("一线缺勤")
        r = .Cells(.Rows.Count, 2).End(3).Row
        arr = .Range("b3:e" & r)
        For i = 1 To UBound(arr)
            Dic(DateValue(arr(i, 1))) = Dic(DateValue(arr(i, 1))) & " " & arr(i, 4)
        Next i
    End With
    With Sheets("一线缺勤姓名转置")
        .Range("a3:b999").ClearContents
        .Range("a3").Resize(Dic.Count, 2) = Application.Transpose(Array(Dic.keys, Dic.items))
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
End Sub

tengyt

先谢谢老师，代码完美解决上面问题了

还有一个问题是：
反过来，据姓名判断，转置日期
老师帮忙改改代码，谢谢老师谢谢老师

幽默小调

Sub 据姓名判断转置日期()
arr = Sheets("缺勤").Range("B3:E" & Sheets("缺勤") _
        .Cells(Rows.Count, 5).End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
For dt = 1 To UBound(arr)
    If d.exists(arr(dt, 4)) Then
        d(arr(dt, 4)) = d(arr(dt, 4)) & " " & arr(dt, 1)
    Else
         d(arr(dt, 4)) = arr(dt, 1)
    End If
Next
Sheets("缺勤转置").Range("a3:b" & Sheets("缺勤转置").Cells(Rows.Count, 2).End(xlUp).Row).Clear
Sheets("缺勤转置").[a3].Resize(d.Count, 1) = Application.Transpose(d.keys)
Sheets("缺勤转置").[b3].Resize(d.Count, 1) = Application.Transpose(d.items)
Set d = Nothing
End Sub