Tienes varios problemas en tus datos que deberás corregir, ya que la macro no puede arreglarlos, y siempre tendrás problemas para ordenar, clasificar, buscar, contar, etc, etc.
Por ejemplo:
- Tienes días con guión 21-mar (21 martes), pero eso para excel es una fecha, entonces para excel es 21 de marzo de 2020.
- Cada nombre debería tener grupos de filas en pares, es decir, una fila con días y la fila de abajo con horarios.
- En varios nombres falta la fila de abajo con los horarios.
- Tienes nombres con espacios en blanco a la izquierda y también a la derecha. Mira el siguiente ejemplo:
- Tienes celdas vacías y celdas con "- -" deberías de homologar, elige uno de los 2 utilízalo en todas las celdas.
- Puse varias condiciones en la macro para conseguir los resultados esperados. Pero deberás hacer las correcciones en tu información. Como te comenté, arreglar tu información evitará otros errores en el futuro.
Prueba la siguiente macro en el archivo que compartiste. El resultado estará en la "Hoja2".
Cambié el estilo de la macro, ahora el proceso es inmediato. Solamente tendrás que aplicar el formato que tú desees en la "Hoja2".
Sub Transponer_Datos()
'DECLARACIÓN DE VARIABLES
Dim h1 As Worksheet, h2 As Worksheet
Dim i As Long, j As Long, k As Long
Dim a As Variant, b As Variant, m As Variant
Dim entra As Boolean
'DATOS INICIALES
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
a = h1.Range("A1:J" & h1.Range("A" & Rows.Count).End(3).Row + 1).Value
ReDim b(1 To UBound(a) * 10, 1 To 3)
'PROCESO
For i = 1 To UBound(a) - 1
If UCase(Left(Trim(a(i, 1)), 1)) Like "[A-Z]" Then
'Copia titulos
k = k + 1
b(k, 1) = a(i, 1)
b(k, 2) = a(i, 5)
b(k, 3) = a(i, 6)
Else
'Copia días y horarios
entra = True
If UCase(Left(Trim(a(i + 1, 1)), 1)) Like "[A-Z]" Then entra = False
If IsDate(a(i + 1, 1)) Then
m = LCase(Format(a(i + 1, 1), "mmm"))
Else
m = LCase(Right(Trim(a(i + 1, 1)), 3))
End If
If m <> "" Then
If "lunmarmiejueviesabdom" Like "*" & m & "*" Then entra = False
End If
For j = 1 To 10
k = k + 1
b(k, 2) = a(i, j)
If entra Then b(k, 3) = a(i + 1, j)
Next
If entra Then i = i + 1
End If
Next
'SALIDA
h2.Range("A:C").ClearContents
h2.Range("A1").Resize(k, 3).Value = b
Application.ScreenUpdating = True
End Sub