Macro demasiado extensa que me gustaría reducirla

Envíame el archivo con la macro a mi correo.

Lo importante, antes de entrar a revisar tu macro, explícame qué es lo que necesitas, tal vez, pueda generar otra macro nueva, con otra perspectiva.

Mi correo [email protected]

En el asunto del correo escribe tu nombre de usuario “Miguel Angel” y el título de esta pregunta.

Listo Dante, ya te acabé de enviar el correo que me pediste que te enviara. Te explique en el correo, paso por paso lo que hace la macro, creo que va super explicado con lujo de detalles. Igualmente como para que te lleves una idea te cuento que en si, la macro hace todo lo que necesito, lo que pasa es que realiza todas esas funciones en un lapso de tiempo de 52 segundos y pienso que es por que es demasiado extensa la macro y pudiera mejorar haciendo que haga lo mismo pero con instrucciones mas livianas. Espero que me puedas ayudar, y gracias de antemano.

H o l a:

En tu macro todo lo que diga:

ActiveWindow. ScrollColumn o ActiveWindow. ScrollRow

Lo puedes eliminar, con eso reduces considerablemente el tamaño de la macro.

Te anexo la macro con las actualizaciones:

Sub REGISTROS()
'Act.Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set h1 = Sheets("VISITAS")
    Set h2 = Sheets("CARTERA")
    '
    h1.Range("C5:C14").Copy
    h2.Range("A20000").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    h1.Range("F5:F14").Copy
    h2.Range("K20000").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    h1.Range("F2").Copy
    h2.Range("U20000").PasteSpecial Paste:=xlPasteValues, Transpose:=False
    h2.Range("V3:Y3").Copy h2.Range("V20000")
    h2.Range("F20000").TextToColumns Destination:=h2.Range("Z20000"), _
        DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 2), Array(1, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True
    h2.Range("AC3").Copy h2.Range("AC20000")
    h2.Range("H20000").TextToColumns Destination:=h2.Range("AD20000"), _
        DataType:=xlDelimited, TextQualifier:=xlNone, _
        ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
        FieldInfo:=Array(Array(1, 2), Array(2, 2)), _
        TrailingMinusNumbers:=True
    h2.Range("AF20000") = "=TEXT(RC[-31],""yyyy"")"
    h2.Range("AG20000") = "=TEXT(RC[-32],""mmmm"")"
    h2.Range("AH20000") = "=IF(RC[-4]="""","""",IF(RC[-4]=""plan"",""Particulares"",RC[-3]))"
    With h2.Sort
        .SortFields.Clear
        .SortFields.Add Key:=h2.Range("A3:A20000"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange h2.Range("A2:AH20000"): .Header = xlYes: .MatchCase = False
        .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
    h1.Range("F2") = h1.Range("F2") + 1
    ActiveWorkbook.Save
End Sub

Eliminé de la macro todos los select, ahora estoy utilizando una variable de objeto para cada hoja:

Set h1 = Sheets("VISITAS")
Set h2 = Sheets("CARTERA")

Y en cada instrucción donde utilizas la hoja, solamente hay que hacer referencia a la variable objeto. Por ejemplo, en la siguiente instrucción, estoy copiando el rango y no es necesario seleccionar la hoja, ni seleccionar el rango:

H1. Range("C5:C14"). Copy

En la siguiente instrucción estoy pegando lo que copié; y tampoco es necesario seleccionar la hoja, ni la celda destino:

h2.Range("A20000").PasteSpecial Paste:=xlPasteValues, Transpose:=True

Al utilizar la referencia de las hojas, ya no es necesario ocultar la aplicación. Tampoco es necesario mostrar la hojas, las hojas pueden permanecer ocultas.

Como la macro ya no está cambiándose de una hoja a otra, ahora el tiempo de ejecución debe reducirse.

Sin embargo, puedes seguir utilizando la grabadora de macros para que te ponga las instrucciones, y después cambiarlas, por ejemplo:

La grabadora te presenta esto:

    Sheets("VISITAS").Select
    Range("F2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("CARTERA").Select
    Range("U20000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Y puedes cambiarlo a esto:

    h1.Range("F2").Copy
    h2.Range("U20000").PasteSpecial Paste:=xlPasteValues, Transpose:=False

'

'

Me faltó la parte de limpiar las celdas:

Sub REGISTROS()
'Act.Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set h1 = Sheets("VISITAS")
    Set h2 = Sheets("CARTERA")
    '
    h1.Range("C5:C14").Copy
    h2.Range("A20000").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    h1.Range("F5:F14").Copy
    h2.Range("K20000").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    h1.Range("F2").Copy
    h2.Range("U20000").PasteSpecial Paste:=xlPasteValues, Transpose:=False
    h2.Range("V3:Y3").Copy h2.Range("V20000")
    h2.Range("F20000").TextToColumns Destination:=h2.Range("Z20000"), _
        DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 2), Array(1, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True
    h2.Range("AC3").Copy h2.Range("AC20000")
    h2.Range("H20000").TextToColumns Destination:=h2.Range("AD20000"), _
        DataType:=xlDelimited, TextQualifier:=xlNone, _
        ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, _
        FieldInfo:=Array(Array(1, 2), Array(2, 2)), _
        TrailingMinusNumbers:=True
    h2.Range("AF20000") = "=TEXT(RC[-31],""yyyy"")"
    h2.Range("AG20000") = "=TEXT(RC[-32],""mmmm"")"
    h2.Range("AH20000") = "=IF(RC[-4]="""","""",IF(RC[-4]=""plan"",""Particulares"",RC[-3]))"
    With h2.Sort
        .SortFields.Clear
        .SortFields.Add Key:=h2.Range("A3:A20000"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange h2.Range("A2:AH20000"): .Header = xlYes: .MatchCase = False
        .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
    H1. Range("F14"). ClearContents
    H1. Range("F12"). ClearContents
    H1. Range("F11"). ClearContents
    H1. Range("F10"). ClearContents
    H1. Range("F7"). ClearContents
    H1. Range("F6"). ClearContents
    H1. Range("F5"). ClearContents
    H1. Range("C14"). ClearContents
    H1. Range("C12"). ClearContents
    H1. Range("C11"). ClearContents
    H1. Range("C10"). ClearContents
    H1. Range("C9"). ClearContents
    H1. Range("C7"). ClearContents
    H1. Range("C6"). ClearContents
    h1.Range("F2") = h1.Range("F2") + 1
    ActiveWorkbook.Save
End Sub

'

Hola Dante

Pensé que adicional a lo que ya hiciste, pensé que seria buena idea que en lugar de copiar los datos en la fila 20.000 para luego ordenar los datos en forma ascendente, no seria bueno también que en lugar de ello, ¿lo qué hiciera la macro es ir de una vez a la primera fila vacía que encuentre en CARTERA y allí poner los datos? Si lo hace, de una vez quedan organizados por la columna Ha dado a que la fecha en que se organizan es la fecha en la que se están registrando.