Macro copia y pega transpuesto un rango de filas variable.
Soy nuevo en esto y veo que usted tiene muchas valoraciones o puntos, es por eso que me acerco a usted para ver si me puede ayudar con esta pregunta, la cual me tratare de explicar mejor a continuación.
En la Hoja 1 Tengo un archivo con 4 columnas (siempre son 4) y "n" cantidad de Filas (siempre varían), las cuales copio y transpongo en la hoja dos de esta manera:
Hoja 1
A B C D
Columna 1 Columna 2 columna 3 columna 4
1 Dato 1 A00 E.1 Valor 1
2 Dato 1 A00 E.2 Valor 2
3 Dato 1 A00 E.3 Valor 3
4 Dato 2 A00 E.1 Valor 4
5 Dato 2 A00 E.2 Valor 5
6 Dato 2 A00 E.3 Valor 6
7 Dato 3 A00 E.1 Valor 7
8 Dato 3 A00 E.2 Valor 8
9 Dato 3 A00 E.3 Valor 9
las copio a la hoja 2 de la siguiente forma.
Hoja 2
A B C D E
Columna 1 Columna 2 E.1 E.2 E.3
1 Dato 1 A00 Valor 1 Valor 2 Valor 3
2 Dato 2 A00 Valor 4 Valor 5 Valor 6
3 Dato 3 A00 Valor 7 Valor 8 Valor 9
... Puntos importantes:
1 ) la columna 1: siempre se repite 3 veces el valor (En este caso: Dato 1, Dato 2 y Dato 3 están 3 veces cada uno)
2) La columna 2 es el mismo valor siempre.
3) La columna 3 es el encabezado que uso para la hoja dos (En este caso E1, E2 y E3, solo lo transpongo una vez para formar los títulos).
4) La columna 4 la transpongo de tres en tres ( en este caso transpongo:
En la fila 1: del Valor 1 a valor 3.
En la fila 2: de valor 4 a valor 6.
En la fila 3: de valor 7 a valor 9 y así sucesivamente
...
1 Respuesta
La macro funciona si en la hoja 1 tienes encabezados en la fila 1:
En la hoja2 el resultado quedará así:
La macro:
Sub CopiarTranspuesto()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
h2.Cells.Clear
h1.[A1:B1].Copy h2.[A1]
h1.[C2:C4].Copy: h2.[C1].PasteSpecial xlValues, Transpose:=True
'
j = 2
For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row Step 3
h1.Range("A" & i & ":B" & i).Copy h2.Cells(j, "A")
h1.Range("D" & i & ":D" & i + 2).Copy
h2.Cells(j, "C").PasteSpecial xlValues, Transpose:=True
j = j + 1
Next
h2.Select
[A1].Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "fin"
End SubAvísame cualquier duda.
' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
