MACRO Copiar Filas según condición en columna
Agradezco de antemano la ayuda que me puedan brindar.
Tengo un proyecto en el trabajo donde estoy desarrollando varias tablas para agilizar algunos procesos; entre ellos, requiero que de una tabla se copien todas las filas acompañadas de las columnas cuyos valores sean distintos de cero (la fila estaría repetida tantas veces como columnas sea distintas de cero)
Ejemplo de Resultado:
Hoja 1 (tabla origen)
País Capital Presidente Gas Petroleo Minerales Tecnologia
Rusia Moscú Putin 4 3 2 5
Venezuela Caracas Chavez 5 3 0 0
EEUU Washington Trump 3 2 2 5
Perú Lima Vizcarra 4 0 5 0
Hoja 2 (en función de la tabla en la hoja 1 se copian las filas incluyendo las columnas con valores diferentes de cero también como filas en una sola columna)
País Capital Presidente Recurso Comentarios
Rusia Moscú Putin Gas
Rusia Moscú Putin Petroleo
Rusia Moscú Putin Minerales
Rusia Moscú Putin Tecnologia
Venezuela Caracas Chavez Gas
Venezuela Caracas Chavez Petroleo
EEUU Washington Trump Gas
EEUU Washington Trump Petroleo
EEUU Washington Trump Minerales
EEUU Washington Trump Tecnologia
Perú Lima Vizcarra Gas
Perú Lima Vizcarra Minerales
Adicional, seria excelente tener un botón que, cuando se cambien los valores en la tabla 1 (los encabezados estarán fijos), se limpien todas las filas de la tabla en la hoja 2 y se ingresen los nuevos.
Esto quizás aporta algo más
Visita https://programarexcel.com descarga cientos de ejemplos de macros grati
2 respuestas más de otros expertos
Te anexo la macro.
Según tu ejemplo en ambas hojas el encabezado está en la fila 1.
Al momento de ejecutar la macro, limpia la hoja2, y después pone todos los recursos.
Sub Copiar_Filas()
'Por Dante Amor
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
h2.Rows("2:" & Rows.Count).ClearContents
k = 2
For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
For j = 4 To h1.Cells(1, Columns.Count).End(xlToLeft).Column
If h1.Cells(i, j).Value > 0 Then
h2.Cells(k, "A").Value = h1.Cells(i, "A").Value
h2.Cells(k, "B").Value = h1.Cells(i, "B").Value
h2.Cells(k, "C").Value = h1.Cells(i, "C").Value
h2.Cells(k, "D").Value = h1.Cells(1, j).Value
k = k + 1
End If
Next
Next
MsgBox "Fin"
End Sub'.[Sal u dos. Dante Amor. No olvides valorar la respuesta. '.[Avísame cualquier duda
Hola Dante Amor
Muy agradecido por tu pronta respuesta, pero lamentablemente olvide mencionar que ambas tablas no se encuentran en los encabezados. Lo he acomodado en la primera fila y tu macro hace exactamente lo que me hace falta.
¿
Podrías ayudarme nuevamente por favor rearmando la macro para que pueda hacer lo mismo pero considerando que las tablas están en medio de la hoja?
Adicionalmente, si no fuera mucha molestia, ¿es posible hacer que también el valor se copie en una columna adicional? Es decir, para rusio, el recurso gas tiene un rating de 4, ¿se puede generar en la tabla 2 una columna que rescate ese numero?
Muchas gracias nuevamente!
Puedes poner un par de imágenes una de la hoja origen y otra de la hoja destino, donde se vean las filas y las columnas de excel.
Hola Dante
Gracias por tu comunicación
La imagen superior seria Sheet1 y la inferior Sheet2; como puedes ver, son varios encabezados que se tendría que evaluar para considerar la duplicidad de filas en Sheet2 (hasta el momento 23, pero pueden aumentar) y lo que decía es que olvide mencionar que el valor también se copie a la columna "Cant Ref" de Sheet2:
Según tu imagen en Sheet1, los encabezados están en la fila 17, la macro está preparada para leer todos las actividades que tengas desde la columna F y hacia la derecha, puedes tener 30 o 500 actividades.
Y según tu imagen en Sheet2, los encabezados están en la fila 22.
Te anexo la macro actualizada
Sub Copiar_Filas()
'Por Dante Amor
Set h1 = Sheets("Sheet1")
Set h2 = Sheets("Sheet2")
k = 23
h2.Rows(k & ":" & Rows.Count).ClearContents
For i = 18 To h1.Range("A" & Rows.Count).End(xlUp).Row
For j = Columns("F").Column To h1.Cells(17, Columns.Count).End(xlToLeft).Column
If h1.Cells(i, j).Value > 0 Then
h2.Cells(k, "A").Value = h1.Cells(i, "A").Value
h2.Cells(k, "B").Value = h1.Cells(i, "B").Value
h2.Cells(k, "C").Value = h1.Cells(i, "C").Value
h2.Cells(k, "F").Value = h1.Cells(1, j).Value
h2.Cells(k, "G").Value = h1.Cells(i, j).Value
k = k + 1
End If
Next
Next
MsgBox "Fin"
End SubAl final de mi respuesta hay un botón para valorar. No olvides valorar la respuesta.
Eres un genio!
Por favor un detalle: en la macro no se están copiando los encabezados de sheet1 a la columna F (Cant Pers) de Sheet2:
Muchas muchas gracias
Va la macro actualizada
Sub Copiar_Filas()
'Por Dante Amor
Set h1 = Sheets("Sheet1")
Set h2 = Sheets("Sheet2")
k = 23
enca = 17
h2.Rows(k & ":" & Rows.Count).ClearContents
For i = enca + 1 To h1.Range("A" & Rows.Count).End(xlUp).Row
For j = Columns("F").Column To h1.Cells(enca, Columns.Count).End(xlToLeft).Column
If h1.Cells(i, j).Value > 0 Then
h2.Cells(k, "A").Value = h1.Cells(i, "A").Value
h2.Cells(k, "B").Value = h1.Cells(i, "B").Value
h2.Cells(k, "C").Value = h1.Cells(i, "C").Value
h2.Cells(k, "F").Value = h1.Cells(enca, j).Value
h2.Cells(k, "G").Value = h1.Cells(i, j).Value
k = k + 1
End If
Next
Next
MsgBox "Fin"
End Sub'.[Sal u dos. Dante Amor. No olvides valorar la respuesta.
La tabla con encabezados en negritas es el resultado de la macro, la tabla a la derecha es el resultado que tu esperas
y esta es la macro
Sub copiar_info()
Set H1 = Worksheets("hoja1")
Set H2 = Worksheets("hoja2")
Set DATOS = H1.Range("a1").CurrentRegion
H2.Range("A2").CurrentRegion.Clear
With DATOS
r = .Rows.Count: c = .Columns.Count
For i = 2 To r
cuenta = WorksheetFunction.CountIf(.Rows(i), ">0")
If i = 2 Then Set DESTINO = H2.Range("a2").Resize(cuenta, 4)
If i > 2 Then Set DESTINO = DESTINO.Rows(DESTINO.Rows.Count + 1).Resize(cuenta, 4)
DESTINO.Columns(1).Value = .Cells(i, 1)
DESTINO.Columns(2).Value = .Cells(i, 2)
DESTINO.Columns(3).Value = .Cells(i, 3)
x = 1
For j = 4 To c
zero = .Cells(i, j) > 0
If zero Then DESTINO.Cells(x, 4).Value = .Cells(1, j): x = x + 1
Next j
Next i
With DESTINO.CurrentRegion
.Cells(0, 1) = "PAIS"
.Cells(0, 2) = "CAPITAL"
.Cells(0, 3) = "PRESIDENTE"
.Cells(0, 4) = "RECURSO"
.Cells(0, 5) = "COMENTARIOS"
.Cells(0, 5).Font.Bold = True
.Rows(0).Font.Bold = True
.EntireColumn.AutoFit
End With
End With
Set H1 = Nothing: Set H2 = Nothing
Set DESTINO = Nothing: Set DATOS = Nothing
End Sub