Sub Consultar()
Application.ScreenUpdating = False
On Error GoTo Mensaje
' Dim Ndocument As Integer
Dim row1 As Integer
Dim row2 As Integer
Dim row3 As Integer
Dim BaseEntrada As Worksheet
Set BaseEntrada = Sheets("BaseEntrada")
Range("B9:B1048576").ClearContents
ActiveSheet.Unprotect "cinventario"
Ndocument = Range("C3")
row1 = Application.WorksheetFunction.Match(Ndocument, Sheets("BaseEntrada").Range("K:K"), False)
row2 = WorksheetFunction.CountIf(Sheets("BaseEntrada").Range("K:K"), Ndocument) + row1 - 1
BaseEntrada.Select
Range("I" & row1).Copy
Sheets("REGISTRAR").Range("C2").PasteSpecial xlPasteValues
Range("A" & row1 & ":M" & row2).Copy
Sheets("REGISTRAR").Select
Range("B9").Select
ActiveCell.PasteSpecial xlPasteValues
Sheets("REGISTRAR").ComboClientes.Value = Range("K9")
ActiveSheet.Unprotect "cinventario"
Range("C5").Value = Range("K9").Text
row3 = Range("B1048576").End(xlUp).Row
Range("C6:D6").Copy Range("C9:D" & row3)
Range("G6:M6").Copy Range("G9:G" & row3)
Range("O6").Copy Range("O9:O" & row3)
Sheets("REGISTRAR").Shapes("GuardarNew").Visible = False
Sheets("REGISTRAR").Shapes("GuardarConsulta").Visible = True
Range("B9:O50").VerticalAlignment = xlCenter
Range("c9:c50").WrapText = True
ActiveSheet.Protect "cinventario", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFiltering:=True
Application.ScreenUpdating = True
Exit Sub
Mensaje:
Application.ScreenUpdating = True
MsgBox "Registro buscado no existe en la base de datos", , "Control de Entradas y Salidas"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim Fila As Integer
Fila = Range("B1048576").End(xlUp).Row 'Esta fila sirve para buscar la ultima fila que contiene datos
Fila2 = Fila + 1 'Esta fila sirve para saber a partir de cual fila tiene que borrar los datos
Fila3 = Fila2 + 500 'Esta fila sirve para saber hasta que fila tiene que borrar los datos
rango = "B9:B1048576"
If Not Application.Intersect(Target, Range(rango)) Is Nothing Then
If Fila > 8 Then
ActiveSheet.Unprotect "cinventario"
Range("C6:D6").Copy Range("C" & Fila)
Range("G6:I6").Copy Range("G" & Fila)
Range("L6:M6").Copy Range("L" & Fila)
Range("O6").Copy Range("O" & Fila)
Range("C" & Fila2 & ":O" & Fila3).ClearContents
Range("B9:O50").VerticalAlignment = xlCenter
Range("c9:c50").WrapText = True
ActiveSheet.Protect "cinventario", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFiltering:=True
Else
ActiveSheet.Unprotect "cinventario"
Range("C" & Fila2 & ":O" & Fila3).ClearContents
ActiveSheet.Protect "cinventario", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFiltering:=True
End If
End If
Application.ScreenUpdating = True
End Sub
Esas son las macros que uso en una hoja, pero antes de ponerla en ejecución yo le aplico a la hoja a través de los controles de Excel el tamaño de letra en 10, alineación vertical en el medio y autoajuste de la celda y guardo el documento, bloqueo la página y ejecuto la macro, con la macro pierde el tamaño de la letra el autoajuste y la alineación, lo que no quiero es hacerlo con código para no poner tan lento la macro con tanta instrucción