Resumir una macro con otra más sencilla

[ssanceb]

Hola a todos, me gustaría saber si conocéis alguna forma de resumir esta macro que he hecho, que lo que hace en definitiva es copiar un rango y transponerlo en la hoja2, con la peculiaridad de que va avanzando de columna cada 6 filas que ha copiado en la hoja 1.

Si os fijáis los únicos parámetros que varían en cada uno de los días que he hecho serían la columna y el número que le resto a la variable h para que me de siempre la fila 3, 10, 17, 24, 31, y 38.

Por otro lado al hacer lo mismo con los días de la semana me da problemas, ¿puede ser porque copio celdas combinadas y al pegarlo son celdas normales?.

Bueno os dejo la macro para que veáis como se ejecuta y si podéis echarme una mano, simplemente porque aunque se ejecuta bien, estoy seguro de que puede hacerse de una forma más fácil y estoy tan encerrado que tal vez la tenga delante y ni me doy cuenta.

Os dejo aquí la macro y subo también archivo por si os puede ayudar en algo.

Muchas gracias de antemano a todos los que hacéis posible que compartamos conocimientos día a día por aquí.

Un saludo.

Sub Transponer()

'************************Evitar parpadeo

Application.ScreenUpdating = False

'************Transponer de Hoja1 a Hoja2

'LUNES

For x = 1 To 6

For j = 3 To 8

Sheets("Hoja1").Select

Range(Cells(x, 3), Cells(x, 8)).Copy

Sheets("Hoja2").Select

h = (x - 1) * 7 + 3

Range("B" & h).PasteSpecial Transpose:=True

Next

Next

'MARTES

For x = 7 To 12

For j = 3 To 8

Sheets("Hoja1").Select

Range(Cells(x, 3), Cells(x, 8)).Copy

Sheets("Hoja2").Select

h = (x - 1) * 7 + 3 - 42

Range("C" & h).PasteSpecial Transpose:=True

Next

Next

'MIÉRCOLES

For x = 13 To 18

For j = 3 To 8

Sheets("Hoja1").Select

Range(Cells(x, 3), Cells(x, 8)).Copy

Sheets("Hoja2").Select

h = (x - 1) * 7 + 3 - 84

Range("D" & h).PasteSpecial Transpose:=True

Next

Next

'JUEVES

For x = 19 To 24

For j = 3 To 8

Sheets("Hoja1").Select

Range(Cells(x, 3), Cells(x, 8)).Copy

Sheets("Hoja2").Select

h = (x - 1) * 7 + 3 - 126

Range("E" & h).PasteSpecial Transpose:=True

Next

Next

'VIERNES

For x = 25 To 30

For j = 3 To 8

Sheets("Hoja1").Select

Range(Cells(x, 3), Cells(x, 8)).Copy

Sheets("Hoja2").Select

h = (x - 1) * 7 + 3 - 168

Range("F" & h).PasteSpecial Transpose:=True

Next

Next

End Sub

Transponer final web.rar