Buenos días!

 

Amigos del foro quisiera solicitarles el apoyo para resolver el siguiente problema, necesito una macro que me permita copiar de una hoja a otra si se cumplen los siguientes criterios:

• Si el valor en la columna G de la hoja Diario es mayor que cero, se copien los datos de Diario(hasta la ultima celda con datos) a la hoja BD pegando los datos en la ultima celda vacía de BD.
• Al copiar aquellos valores mayores a cero en la hoja BD quitarlos de la hoja Diario, solamente dejando los datos que contengan cero o se encuentren vacios en la columna G de la hoja Diario.

Lo estuve intentando de la siguiente manera:

Sub copiar2()

    Set J1 = Sheets("Diario")
    Set J2 = Sheets("BD")
    j = J2.Range("A" & Rows.Count).End(xlUp).Row + 1
    For i = 3 To 79
        If J1.Cells(i, "G") > 0 Then
            J2.Cells(i, "A") = J1.Cells(i, "A")
            J2.Cells(i, "B") = J1.Cells(i, "B")
            J2.Cells(i, "C") = J1.Cells(i, "C")
            J2.Cells(i, "D") = J1.Cells(i, "D")
            J2.Cells(i, "E") = J1.Cells(i, "E")
            J2.Cells(i, "F") = J1.Cells(i, "F")
            J2.Cells(i, "G") = J1.Cells(i, "G")
            J2.Cells(i, "H") = J1.Cells(i, "H")
            J2.Cells(i, "I") = J1.Cells(i, "I")
            J2.Cells(i, "J") = J1.Cells(i, "J")
            J2.Cells(i, "K") = J1.Cells(i, "K")
            J2.Cells(i, "L") = J1.Cells(i, "L")
            J2.Cells(i, "M") = J1.Cells(i, "M")
            J2.Cells(i, "N") = J1.Cells(i, "N")
        End If
    Next
    MsgBox "Valores copiados"
End Sub

Saludos

JB

Consulta copiado.xlsm

Hola Jose BN, prueba el adjunto y comenta.

Consulta copiadoPrueba1.xlsm

Checa el archivo:

Sub Copia()
Application.ScreenUpdating = False
Dim Uf As String
Dim Ul As Long

    Ul = Hoja2.Range("G" & Rows.Count).End(xlUp).Row + 2
            Uf = Hoja1.Range("G" & Rows.Count).End(xlUp).Row
                Hoja1.Range("A2:N" & Uf).AutoFilter Field:=7, Criteria1:=">0"
                    Hoja1.Range("A3:N10000").SpecialCells(xlCellTypeVisible).Copy Destination:=Hoja2.Cells(Ul, 1)

Hoja1.Range("A3:N" & Uf).EntireRow.Delete
Hoja1.Range("A2:N" & Uf).AutoFilter

Application.ScreenUpdating = True
End Sub

 

Copia de Consulta copiado.xlsm

Hace 38 minutos , JSDJSD dijo:

Hola Jose BN, prueba el adjunto y comenta.

Consulta copiadoPrueba1.xlsm 36.5 kB · 1 descarga

Te ha quedado de lujo! muchas gracias...

Me alegro que sea de utilidad, un saludo.

Hace 56 minutos , DiegoLG dijo:

Checa el archivo:

Sub Copia()
Application.ScreenUpdating = False
Dim Uf As String
Dim Ul As Long

    Ul = Hoja2.Range("G" & Rows.Count).End(xlUp).Row + 2
            Uf = Hoja1.Range("G" & Rows.Count).End(xlUp).Row
                Hoja1.Range("A2:N" & Uf).AutoFilter Field:=7, Criteria1:=">0"
                    Hoja1.Range("A3:N10000").SpecialCells(xlCellTypeVisible).Copy Destination:=Hoja2.Cells(Ul, 1)

Hoja1.Range("A3:N" & Uf).EntireRow.Delete
Hoja1.Range("A2:N" & Uf).AutoFilter

Application.ScreenUpdating = True
End Sub

Diego igual muchas gracias! 

Copia de Consulta copiado.xlsm 39.44 kB · 2 descargas

 

Tema solucionado!