Mejorar macro que almacena datos de clientes en otra hoja
Tengo la siguiente macro la cual funciona correctamente:
Sub ALMACENAR()
Set h2 = Sheets("CLIENTES")
Set h3 = Sheets("FORMULARIO")
'
If h3.[E7] = "" Then
MsgBox "Ingrese el ID en la celda E7", vbExclamation
[E7].Select
Exit Sub
End If
'
Set b = h2.Columns("C").Find(h3.[E7], lookat:=xlWhole)
If Not b Is Nothing Then
MsgBox "El Paciente ya existe en la Base de Datos.", vbExclamation
Else
Application.Visible = False
Range("E5:E16").Select
Selection.Copy
Application.ScreenUpdating = False
For Each n In Sheets
n.Visible = True
Next n
Application.ScreenUpdating = True
Sheets("CLIENTES").Select
Range("A20000").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("F2").Select
Application.CutCopyMode = False
Selection.Copy
Range("F20000").Select
ActiveSheet.Paste
Range("A1:L20000").Select
Range("L20000").Activate
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("CLIENTES").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("CLIENTES").Sort.SortFields.Add Key:=Range( _
"A2:A20000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("CLIENTES").Sort
.SetRange Range("A1:L20000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2").Select
Sheets("FORMULARIO").Select
Application.Run "CONSULTORIO.xlsm!ocultar_hojas"
Range("E11:E16").Select
Range("E16").Activate
Selection.ClearContents
Range("E6:E9").Select
Range("E9").Activate
Selection.ClearContents
Application.Visible = True
Range("E6").Select
ActiveWorkbook.Save
End If
End SubLa hice con el formato de grabar macros pero sé que tu me la puedes ayudar a mejorar en un aspecto y es que en lugar de ir a copiar los datos de la hoja "Formulario" a la hoja "Clientes" en la fila 20.000 y luego filtrarlos, quisiera que en lugar de ello, se fueran agregando uno debajo del otro cuando encuentre una fila vacia con respecto a la columna "A". Tal vez así la macro dure mucho menos de tiempo en su ejecución.
1 Respuesta
Respuesta de Dante Amor
1
H o l a:
Te anexo la macro actualizada, de esta forma ya no es necesario, ocultar la aplicación, ni mostrar las hojas, ni volver a ocultar las hojas.
Sub ALMACENAR()
'Por.Dante Amor
Set h2 = Sheets("CLIENTES")
Set h3 = Sheets("FORMULARIO")
'
If h3.[E7] = "" Then
MsgBox "Ingrese el ID en la celda E7", vbExclamation
[E7].Select
Exit Sub
End If
'
Set b = h2.Columns("C").Find(h3.[E7], lookat:=xlWhole)
If Not b Is Nothing Then
MsgBox "El Paciente ya existe en la Base de Datos.", vbExclamation
Else
h3.Range("E5:E16").Copy
u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
h2.Cells(u, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
h2.Range("F2").Copy h2.Cells(u, "F")
h3.Range("E6:E9").ClearContents
h3.Range("E11:E16").ClearContents
ActiveWorkbook.Save
MsgBox "Paciente registrado", vbInformation
End If
End Subs a l u d o s
