Repetir el trabajo en las dos líneas

Este código funciona bien pero lo tiene que hacer dos veces, fila 2 y fila 3 tiene que hacer lo mismo

' Macro3 Macro
'
' Acceso directo: CTRL+q
'
If Range("a2").Value = "" Then
res = MsgBox("No existe fecha : " & hoja & vbCr & _
" Quieres darla de alta", vbQuestion + vbYesNo, "")
If res = vbNo Then
Exit Sub
End If
If res = vbYes Then
Exit Sub
Range("a2").Select
ActiveCell.Offset(0, 0).Select
End If
End If

ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=1
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=2
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=3
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=4
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=5

Range("b2").Select
If ActiveCell.Offset(1, 0).Value = "" Then
Range("b2").Copy
Range("b3").Select
ActiveCell.PasteSpecial xlValues
Application.CutCopyMode = False
End If
Call macro6
'Act.Por.Dante Amor
Set h1 = Sheets("LIBRO DIARIO")
hoja = Sheets("LIBRO DIARIO").[C2].Value
existe = False
For Each h In Sheets
If LCase(h.Name) = LCase(hoja) Then
existe = True
Exit For
End If
Next
If existe = False Then
res = MsgBox("No existe la hoja : " & hoja & vbCr & _
" Quieres darla de alta", vbQuestion + vbYesNo, "ALTA HOJA")
If res = vbNo Then Exit Sub
Sheets("formato").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = hoja
End If
'
Application.Goto Sheets(Sheets("LIBRO DIARIO").[C2].Text).[C2]
Range("A2").Select
On Error Resume Next
ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
'werr = Err.Number
'If werr <> 0 Then
' ActiveSheet.Range("A1").Offset(1, 0).Select
'End If
'Acá COPIE LA PARTE NUEVA ----------------

h1.Range("A2:E2").Copy
ActiveCell.PasteSpecial xlValues
ActiveCell.PasteSpecial Paste:=xlPasteColumnWidths
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Insert
'
'--------- Actualiza balance
If existe = False Then
Set h2 = Sheets("BALANCE")
u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
h2.Range("A" & u) = hoja
h2.Range("B" & u) = Sheets(hoja).[F2]
End If
'----------- ACA REGRESA AL LIBRO --------------------------
Sheets("libro diario").Select
Range("A2").Select
Range("A2:E2"). ClearContents
Range("B3:C3"). ClearContents
End Sub

1 Respuesta

Respuesta
1

Te anexo la macro actualizada

Sub Macro3()
'
' Macro3 Macro
'
' Acceso directo: CTRL+q
'
If Range("a2").Value = "" Then
      res = MsgBox("No existe fecha : " & hoja & vbCr & _
                     " Quieres darla de alta", vbQuestion + vbYesNo, "")
      If res = vbNo Then
      Exit Sub
       End If
       If res = vbYes Then
       Exit Sub
        Range("a2").Select
        ActiveCell.Offset(0, 0).Select
      End If
End If
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=1
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=2
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=3
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=4
ActiveSheet.Range("$A$5:$E$13").AutoFilter Field:=5
Range("b2").Select
If ActiveCell.Offset(1, 0).Value = "" Then
  Range("b2").Copy
   Range("b3").Select
   ActiveCell.PasteSpecial xlValues
   Application.CutCopyMode = False
 End If
   Call macro6
    'Act.Por.Dante Amor
    Set h1 = Sheets("LIBRO DIARIO")
    hoja = Sheets("LIBRO DIARIO").[C2].Value
    existe = False
    For Each h In Sheets
        If LCase(h.Name) = LCase(hoja) Then
            existe = True
            Exit For
        End If
    Next
    If existe = False Then
        res = MsgBox("No existe la hoja : " & hoja & vbCr & _
                     " Quieres darla de alta", vbQuestion + vbYesNo, "ALTA HOJA")
        If res = vbNo Then Exit Sub
        Sheets("formato").Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = hoja
    End If
    '
    Application.Goto Sheets(Sheets("LIBRO DIARIO").[C2].Text).[C2]
    Range("A2").Select
    On Error Resume Next
    ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
     'AcA COPIE LA PARTE NUEVA  ----------------
    h1.Range("A2:E2").Copy
    ActiveCell.PasteSpecial xlValues
    ActiveCell.PasteSpecial Paste:=xlPasteColumnWidths
    Application.CutCopyMode = False
    'ActiveCell.Offset(1, 0).Select
    'ActiveCell.EntireRow.Insert
    '
    '--------- Actualiza balance
    If existe = False Then
        Set h2 = Sheets("BALANCE")
        u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
        h2.Range("A" & u) = "=" & hoja & "!C3"
        h2.Range("B" & u) = "=" & hoja & "!F2"
    End If
    'Para la cuenta DOS
    hoja = Sheets("LIBRO DIARIO").[C3].Value
    existe = False
    For Each h In Sheets
        If LCase(h.Name) = LCase(hoja) Then
            existe = True
            Exit For
        End If
    Next
    If existe = False Then
        res = MsgBox("No existe la hoja : " & hoja & vbCr & _
                     " Quieres darla de alta", vbQuestion + vbYesNo, "ALTA HOJA")
        If res = vbNo Then Exit Sub
        Sheets("formato").Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = hoja
    End If
    '
    Application.Goto Sheets(Sheets("LIBRO DIARIO").[C3].Text).[C3]
    Range("A2").Select
    On Error Resume Next
    ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
     'AcA COPIE LA PARTE NUEVA  ----------------
    h1.Range("A3:E3").Copy
    ActiveCell.PasteSpecial xlValues
    ActiveCell.PasteSpecial Paste:=xlPasteColumnWidths
    Application.CutCopyMode = False
    'ActiveCell.Offset(1, 0).Select
    'ActiveCell.EntireRow.Insert
    '
    '--------- Actualiza balance
    If existe = False Then
        Set h2 = Sheets("BALANCE")
        u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
        h2.Range("A" & u) = "=" & hoja & "!C3"
        h2.Range("B" & u) = "=" & hoja & "!F2"
    End If
    '-----------  ACA  REGRESA AL LIBRO --------------------------
    Sheets("libro diario").Select
    Range("A2").Select
    Range("A2:E2"). ClearContents
    Range("B3:C3"). ClearContents
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas