Macro para copiar filas de una tabla de acuerdo a un valor
Quisiera saber si alguien me puede ayudar con una macro que copie filas de una tabla que se encuentra en una hoja1, hacia otra hoja2 del mismo libro.
La tabla en cuestión tiene varias columnas, lo que me interesa es que recorra la columna FUNCIONA y copie aquellas filas donde la celda muestra el valor X (Los valores de esta columna son X o celdas vacias). Dichas filas, serán copiadas en una hoja2, por debajo de los últimos valores presentes (de esta manera, no se superponen los datos).
1 respuesta
Esta macro busca la palabra función, determina en que columna se encuentra, ordena la información de forma ascendente agrupando todas las POR las cuales copia en un solo paso a la hoja 2, si ya hay datos en la hoja 2 entonces coloca los datos abajo de la ultima fila de datos, dejando la información de la hoja 1 como estaba inicialmente, solo modifica las partes que dicen hoja1, hoja2 y a2 adecuándola a tus datos.
Sub copiar()
Dim funcion As WorksheetFunction
Set funcion = WorksheetFunction
Set h1 = Worksheets("hoja1")
Set h2 = Worksheets("hoja2")
Set origen = h1.Range("a2").CurrentRegion
With origen
r = .Rows.Count: c = .Columns.Count
Set busca = .Rows(1).Find("funciona")
col = busca.Column
Set indice = .Columns(c + 1).Resize(r, 1)
indice.Cells(1, 1) = 1
Range(indice.Cells(1, 1).Address).AutoFill Destination:=Range(indice.Address), Type:=xlFillSeries
Set origen = .CurrentRegion
.Sort key1:=h1.Range(Columns(4).Address), order1:=xlAscending, Header:=xlYes
cuenta = funcion.CountIf(.Columns(col), "x")
Set origen = .Resize(cuenta + 1)
End With
Set destino = h2.Range("a2").CurrentRegion
With destino
fi = .Rows.Count: ci = .Columns.Count
If fi = 1 And ci = 1 Then
Set destino = .Resize(cuenta + 1, c):
origen.Copy
Else
Set destino = .Rows(fi).Resize(cuenta, c)
origen.Rows(2).Resize(cuenta).Copy
End If
destino.PasteSpecial
destino.Columns(.Columns.Count + 1).ClearContents
End With
With origen
Set origen = .CurrentRegion
c = .Columns.Count
origen.Sort key1:=h1.Range(.Columns(c).Address), order1:=xlAscending, Header:=xlYes
.Columns(c).ClearContents
End With
End Sub
