Mejorar Macro ya creada quitándole una instrucción
Como te decía en la pregunta anterior, seria bueno que en lugar de ordenar los datos de forma ascender, me pudieras ayudar a que los vaya registrando en la siguiente fila vacía que encuentre en la hoja "CARTERA" así de esta manera yo creo que podemos también reducir el tiempo de ejecución de la macro considerablemente. Ya la probé la nueva que me diste y pasó de 52 segundos a 37 segundos.
Te mando la macro nuevamente
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
1 Respuesta
Respuesta de Dante Amor
1
H o l a:
Te anexo la macro para poner la información en la siguiente fila vacía:
Sub REGISTROS()
'Act.Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("VISITAS")
Set h2 = Sheets("CARTERA")
'
u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
h1.Range("C5:C14").Copy: h2.Range("A" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
h1.Range("F5:F14").Copy: h2.Range("K" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
h1.Range("F2").Copy: h2.Range("U" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=False
h2.Range("V3:Y3").Copy h2.Range("V" & u)
h2.Range("F" & u).TextToColumns Destination:=h2.Range("Z" & u), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 2), Array(1, 1), Array(4, 1)), TrailingMinusNumbers:=True
h2.Range("AC3").Copy h2.Range("AC" & u)
h2.Range("H" & u).TextToColumns Destination:=h2.Range("AD" & u), _
DataType:=xlDelimited, TextQualifier:=xlNone, ConsecutiveDelimiter:=True, _
FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
h2.Range("AF" & u) = "=TEXT(RC[-31],""yyyy"")"
h2.Range("AG" & u) = "=TEXT(RC[-32],""mmmm"")"
h2.Range("AH" & u) = "=IF(RC[-4]="""","""",IF(RC[-4]=""plan"",""Particulares"",RC[-3]))"
'
H1. Range("F5:F7"). ClearContents
H1. Range("F10:F12"). ClearContents
H1. Range("F14"). ClearContents
H1. Range("C6:C7"). ClearContents
H1. Range("C9:C12"). ClearContents
H1. Range("C14"). ClearContents
h1.Range("F2") = h1.Range("F2") + 1
End SubTambién se demora porque estás guardando el archivo y si el archivo es muy grande la macro se tarda, pero el proceso debería tomar un par de segundos.
Prueba la nueva macro y me comentas.
'
