Транспонирование таблицы Excel с заголовками дат и столбцов с именами, временем входа и выхода для расписания

Question

У меня есть табель рабочего времени с заголовками: Имя сотрудника, Время входа / выхода и диапазон дат.

Похоже, это скопировано в больший объем.

Тем не менее, желаемый формат для «транспонирования» это:

Мы также получаембольшой объем таких таблиц, поэтому ручное перемещение не требуется.

Answer 1

TR Общая идея состоит в том, чтобы циклически перебирать исходные данные, идентифицируя имена, дату и время. Затем построить сборку новой таблицы в требуемом макете.

Выполнение этого с помощью Variant Arrays сделает его довольно быстрым.

Примерно так

Sub TransposeTime(wsSrc As Worksheet, Optional wsDst As Worksheet)
    Dim rSrc As Range, rDst As Range
    Dim Src As Variant, Dst As Variant
    Dim EmployeeCount As Long
    Dim DateCount As Long
    Dim SrcRow As Long, DstRow As Long, DateRow As Long

    On Error GoTo EH

    If wsSrc Is Nothing Then Exit Sub

    ' Get reference to source data.  Use Column B to get number of rows
    With wsSrc
        Set rSrc = .Range(.Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 1), .Cells(1, .Columns.Count).End(xlToLeft))
    End With

    ' Put source data in a Variant Array
    Src = rSrc.Value2

    ' Count Employees and Dates
    EmployeeCount = Application.CountA(rSrc.Columns(1)) - 1
    DateCount = Application.CountA(rSrc.Rows(1)) - 2

    ' if wsDst is missing, overwrite source
    If wsDst Is Nothing Then
        Set wsDst = wsSrc
        wsSrc.UsedRange.Clear
    End If

    ' Size destination array
    ReDim Dst(0 To EmployeeCount * DateCount, 1 To 4)

    ' Headers
    Dst(0, 1) = "Employee Name"
    Dst(0, 2) = "Date"
    Dst(0, 3) = "Time In"
    Dst(0, 4) = "Time Out"

    ' Loop source data, process each Time In row
    DstRow = 0
    For SrcRow = 1 To UBound(Src, 1)
        If StrComp(Src(SrcRow, 2), "Time In", vbTextCompare) = 0 Then
            ' Loop dates for each employee
            For DateRow = 1 To DateCount
                Dst(DateRow + DstRow, 1) = Src(SrcRow, 1) 'Name
                Dst(DateRow + DstRow, 2) = Src(1, DateRow + 2) 'Date
                If Not IsEmpty(Src(SrcRow, DateRow + 2)) Then
                    Dst(DateRow + DstRow, 3) = Src(SrcRow, DateRow + 2) ' In
                    Dst(DateRow + DstRow + 1, 4) = Src(SrcRow + 1, DateRow + 2) ' Out
                End If
            Next
            DstRow = DstRow + DateCount
        End If
    Next

    ' Place result on sheet
    Set rDst = wsDst.Cells(1, 1).Resize(UBound(Dst, 1) + 1, UBound(Dst, 2))
    rDst.Value = Dst

    ' Format Date and Time Columns
    rDst.Columns(2).NumberFormat = "mm/dd/yyyy"
    rDst.Columns(3).Resize(, 2).NumberFormat = "h:mm:ss AM/PM"

Exit Sub
EH:
    ' on error restore source data
    If Not IsEmpty(Src) Then
        wsSrc.Cells(1, 1).Resize(UBound(Src, 1), UBound(Src, 2)).Value = Src
    End If
    MsgBox "Oops..."
End Sub

Поскольку вам нужно обработать много листов, вам понадобится еще один Sub обработать их и назвать это Sub

Демонстрация вызова для одного листа

Sub Demo()
    TransposeTime ActiveSheet
End Sub

Answer 2

Если это именно то, что кажется, самый простой способ сделать это вручную - выбрать копию всей таблицы. Затем щелкните правой кнопкой мыши в другой области и выберите «Специальная вставка». Установите флажок «Транспонировать» и нажмите кнопку «ОК».

Если вы хотите автоматизировать это, вы можете записать макрос, который выполняет шаги. Остерегайтесь того, как вы выбираете свои данные, чтобы при повторном запуске макроса он выделил все данные вместо прямоугольника с такими же размерами, как при записи макроса.