Macro reemplazar ceros por celdas vacías en un ciclo

Es un gusto volver a saludarlos.

Para Dante Amor:

La siguiente macro, copia y pega datos de un ciclo en una nueva hoja.
Si es posible, necesito por favor su ayuda para que posterior a pegar los datos en E2:V2(hoja2), se elimimen los ceros y se reemplacen por celdas vacías.

Muchas gracias!

Sub Copiar()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    Set b = h1.Columns("A").Find("Saldo", lookat:=xlPart, searchdirection:=xlPrevious)
    If Not b Is Nothing Then
        fila = b.Row
    Else
        fila = h1.Range("A" & Rows.Count).End(xlUp).Row
    End If
    h2.Select
    h2.Pictures.Delete
    h1.Select
    '
    For i = 2 To fila Step 41
        h1.Range(h1.Cells(i, "B"), h1.Cells(i, "D")).Copy h2.Cells(i, "B")
        h1.Range(h1.Cells(i - 1, "E"), h1.Cells(i - 1, "V")).Copy h2.Cells(i - 1, "E")
        H1. Range(h1. Cells(i + 39, "E"), h1.Cells(i + 39, "V")). Copy
h2.Cells(i, "E"). PasteSpecial xlValues
        For Each p In ActiveSheet.Pictures
            If Not Intersect(p.TopLeftCell, h1.Range(h1.Cells(i, "A"), h1.Cells(i + 39, "C"))) Is Nothing Then
                p.Select
                alt = p.Top
                izq = p.Left
                Selection.Copy
                h2.Paste
                h2.Select
                Selection.Top = alt
                Selection.Left = izq
                h1.Select
                Exit For
            End If
        Next
    Next
    '
    MsgBox "Terminado"
End Sub

1 Respuesta

Respuesta
1

H o l a:

Te anexo la macro actualizada

Sub Copiar()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    Set b = h1.Columns("A").Find("Saldo", lookat:=xlPart, searchdirection:=xlPrevious)
    If Not b Is Nothing Then
        fila = b.Row
    Else
        fila = h1.Range("A" & Rows.Count).End(xlUp).Row
    End If
    h2.Select
    h2.Pictures.Delete
    h1.Select
    '
    For i = 2 To fila Step 41
        h1.Range(h1.Cells(i, "B"), h1.Cells(i, "D")).Copy h2.Cells(i, "B")
        h1.Range(h1.Cells(i - 1, "E"), h1.Cells(i - 1, "V")).Copy h2.Cells(i - 1, "E")
        H1. Range(h1. Cells(i + 39, "E"), h1.Cells(i + 39, "V")). Copy
 h2.Cells(i, "E"). PasteSpecial xlValues
        For Each c In h2.Range(h2.Cells(i, "E"), h2.Cells(i, "V"))
            If c.Value = 0 Then c.Value = ""
        Next
        For Each p In ActiveSheet.Pictures
            If Not Intersect(p.TopLeftCell, h1.Range(h1.Cells(i, "A"), h1.Cells(i + 39, "C"))) Is Nothing Then
                p.Select
                alt = p.Top
                izq = p.Left
                Selection.Copy
                h2.Paste
                h2.Select
                Selection.Top = alt
                Selection.Left = izq
                h1.Select
                Exit For
            End If
        Next
    Next
    '
    MsgBox "Terminado"
End Sub

S a l u d o s . D a n t e   A m o r. Recuerda valorar la respuesta. G r a c i a s

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas