![]()
Sub test() Dim a, i As Long, ii As Long, n As Long, AL As Object Dim myDate As Date Set AL = CreateObject("System.Collections.ArrayList") With Sheets("sheet1") a = .Range("b2", .Cells.SpecialCells(11)).Value End With With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(a, 1) If a(i, 1) = "Employee" Then For ii = 2 To UBound(a, 2) If a(i, ii) Like "*##/##/####" Then a(i, ii) = Replace(a(i, ii), vbLf, "") a(i, ii) = DateSerial(Val(Right$(a(i, ii), 4)), _ Val(Mid$(a(i, ii), 7, 2)), Val(Mid$(a(i, ii), 4, 2))) End If Next n = i Else If a(i, 1) <> "" Then If Not .exists(a(i, 1)) Then Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary") End If For ii = 2 To UBound(a, 2) If IsDate(a(n, ii)) Then If Not AL.Contains(a(n, ii)) Then AL.Add a(n, ii) .Item(a(i, 1))(a(n, ii)) = a(i, ii) End If Next End If End If Next ReDim a(1 To .Count + 2, 1 To AL.Count + 1): AL.Sort For ii = 0 To AL.Count - 1 a(1, ii + 2) = AL(ii): a(2, ii + 2) = AL(ii) Next For i = 0 To .Count - 1 a(i + 3, 1) = .keys()(i) For ii = 2 To UBound(a, 2) a(i + 3, ii) = .items()(i)(a(1, ii)) Next Next End With With Sheets.Add.[b1].Resize(UBound(a, 1), UBound(a, 2)) .Value = a .Offset(, 1).Resize(2, .Columns.Count - 1).BorderAround Weight:=2 .Rows(1).NumberFormat = "yyyy/m/d" .Rows(2).NumberFormat = "ddd""""dd/mm/yyyy" .Columns(1).Offset(2).Resize(.Rows.Count - 2).Borders.Weight = 2 .WrapText = False .Columns.AutoFit .Rows.AutoFit .Offset(, 1).HorizontalAlignment = xlCenter With .Offset(2, 1).Resize(.Rows.Count - 2, .Columns.Count - 1) .Borders(11).LineStyle = xlDot .Borders(12).Weight = 2 .BorderAround Weight:=2 End With For ii = 2 To .Columns.Count Step 7 .Columns(ii).Borders(7).LineStyle = 1 Next End With End Sub
Bookmarks