Sub ertert()
Dim x, y(), i&, j&, k&, n&

With Sheets("Учет")
    x = .Range("A1:AH" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).Value
End With
ReDim y(1 To UBound(x) * 1.5, 1 To 34): k = -2

For i = 1 To UBound(x)
    If Len(x(i, 3)) = 4 Then
        k = k + 3
        y(k, 1) = x(i, 1): y(k + 1, 1) = x(i, 1): y(k + 2, 1) = x(i, 1)  'ФИО
        y(k, 2) = x(i, 3): y(k + 1, 2) = x(i, 3): y(k + 2, 2) = x(i, 3)    'Табельный номер
        y(k, 3) = "Ночная": y(k + 1, 3) = "Дневная": y(k + 2, 3) = "Явка"    'Вид явки
        For j = 4 To UBound(x, 2)
            Select Case x(i, j)
                Case "Н": n = 0
                Case "Д": n = 1
                Case "Я": n = 2
                Case Else: n = 100
            End Select
            If n < 100 Then y(k + n, j) = x(i + 1, j)
        Next j

    End If
Next i

With Sheets("Для импорта")
    .Range("A1").CurrentRegion.Offset(1).ClearContents
    .Range("A2").Resize(k + 3, UBound(y, 2)).Value = y()
    .Activate
End With
End Sub

Sub qwerty()
Dim shI As Worksheet
Set shI = Sheets("Импорт")
rc = 2
For x = 3 To 4
    With Sheets(x)
        For y = 5 To .Cells(Rows.Count, 1).End(xlUp).Row Step 2
        shI.Range(Cells(rc, 1), Cells(rc + 2, 1)).Value = .Cells(y, 1).Value
        shI.Range(Cells(rc, 2), Cells(rc + 2, 2)).Value = .Cells(y, 3).Value
        shI.Cells(rc, 3).Value = "ночная"
        shI.Cells(rc + 1, 3).Value = "дневная"
        shI.Cells(rc + 2, 3).Value = "явка"
            For col = 4 To .Cells(4, Columns.Count).End(xlToLeft).Column
            Select Case .Cells(y, col).Value
            Case "Н"
            shI.Cells(rc, col).Value = .Cells(y, col).Offset(1, 0).Value
            Case "Д"
            shI.Cells(rc + 2, col).Value = .Cells(y, col).Offset(1, 0).Value
            Case "Я"
            shI.Cells(rc + 2, col).Value = .Cells(y, col).Offset(1, 0).Value
            End Select
            Next col
        rc = rc + 3
        Next y
        End With
        Next x
End Sub