Location via proxy:   [ UP ]  
[Report a bug]   [Manage cookies]                

Autoexec CFG

Descargar como docx, pdf o txt
Descargar como docx, pdf o txt
Está en la página 1de 22

BOTON GUARDAR FORMULARIO EXCEL

Private Sub GRABAR_Click()


Sheets("ARTICULOS").Select
NR = Application.WorksheetFunction.CountA(Range("B:B"))

If TXTCODIGO = "" Then


MsgBox "INGRESE CODIGO"
TXTCODIGO.SetFocus

Exit Sub

End If
If TXTDESCRIPCION = "" Then
MsgBox "INGRESE DESCRIPCION"
TXTDESCRIPCION.SetFocus
Exit Sub
End If
If TXTCANTIDAD = "" Then
MsgBox "INGRESE CANTIDAD"
TXTCANTIDAD.SetFocus
Exit Sub
Else
If Not (IsNumeric(TXTCANTIDAD)) Then
MsgBox "LA CANTIDAD DEBE SER NUMEROS"
TXTCANTIDAD = ""
TXTCANTIDAD.SetFocus
Exit Sub
End If
End If
If TXTPRECIO = "" Then
MsgBox "INGRESE PRECIO"
TXTPRECIO.SetFocus
Exit Sub
Else
If Not (IsNumeric(TXTPRECIO)) Then
MsgBox "EL PRECIO DEBE SER NUMEROS"
TXTPRECIO = ""
TXTPRECIO.SetFocus
Exit Sub
End If
End If

Cells(NR + 3, 2) = TXTCODIGO
Cells(NR + 3, 3) = TXTDESCRIPCION
Cells(NR + 3, 4) = Val(TXTCANTIDAD)
Cells(NR + 3, 5) = Val(TXTPRECIO)

TXTCODIGO = ""
TXTDESCRIPCION = ""
TXTCANTIDAD = ""
TXTPRECIO = ""
TXTCODIGO.SetFocus
End Sub

Private Sub CMDSALIR_Click()


frminicio.Hide
End Sub

´SOW MUESTRA UN FORMULARIO


´HIDE OCULTA EL FORMULARIO

End Sub

Private Sub CommandButton1_Click()

End Sub

Private Sub CommandButton2_Click()

End Sub

Private SubGRABAR_Click()
Sheets("ARTICULOS").Select
NR = Application.WorksheetFunction.CountA(Range("B:B"))

If TXTCODIGO = "" Then


MsgBox "INGRESE CODIGO"
TXTCODIGO.SetFocus

Exit Sub
End If
If TXTDESCRIPCION = "" Then
MsgBox "INGRESE DESCRIPCION"
TXTDESCRIPCION.SetFocus
Exit Sub
End If
If TXTCANTIDAD = "" Then
MsgBoox "INGRESE CANTIDAD"
TXTCANTIDAD.SetFocus
Exit Sub
Else
If Not (IsNumeric(TXTCANTIDAD)) Then
MsgBox "LA CANTIDAD DEBE SER NUMEROS"
TXTCANTIDAD = ""
TXTCANTIDAD.SetFocus
Exit Sub
End If

End If
If TXTPRECIO = "" Then
MsgBox "INGRESE PRECIO"
TXTPRECIO.SetFocus
Exit Sub
Else
If Not (IsNumeric(TXTPRECIO)) Then
MsgBox "EL PRECIO DEBE DER NUMERO"
TXTPRECIO = ""
TXTPRECIO.SetFocus
Exit Sub
End If
End If

Cells(NR + 2, 1) = TXTCODIGO
Cells(NR + 2, 2) = TXTDESCRIPCION
Cells(NR + 2, 3) = Val(TXTCANTIDAD)
Cells(NR + 2, 4) = Val(TXTPRECIO)

TXTCODIGO = ""
TXTDESCRIPCION = ""
TXTCANTIDAD = ""
TXTPRECIO = ""
TXTCODIGO.SetFocus

End Sub

Private Sub SALIR_Click()


frminicio.Hide

End Sub

Private Sub UserForm_Click()

End Sub
BOTON SALIR DEL FORMULARIO EXCEL
TXTPRECIO.SetFocus
Exit Sub
Else
If Not (IsNumeric(TXTPRECIO)) Then
MsgBox "EL PRECIO DEBE DER NUMERO"
TXTPRECIO = ""
TXTPRECIO.SetFocus
Exit Sub
End If
End If

Cells(NR + 2, 1) = TXTCODIGO
Cells(NR + 2, 2) = TXTDESCRIPCION
Cells(NR + 2, 3) = Val(TXTCANTIDAD)
Cells(NR + 2, 4) = Val(TXTPRECIO)

TXTCODIGO = ""
TXTDESCRIPCION = ""
TXTCANTIDAD = ""
TXTPRECIO = ""
TXTCODIGO.SetFocus

End Sub

Private Sub SALIR_Click()


frminicio.Hide
End Sub

Private Sub UserForm_Click()

End Sub

MODULO PARA FORMULARIO


Sub frminicio_Haga_clic_en()
Load frminicio
frminicio.Show

End Sub

HOJA UNO DE FORMULARIO


Private Sub CMDINICIO_Click()
frminicio.Show
End Sub

BOTONES PARA REGISTRO CON INTERSES LIMPIAR Y REGISTRAR


Private Sub LIMPIAR_Click()
Sistema_de_pagos.TextBox1.Value = ""
Sistema_de_pagos.TextBox2.Value = ""
Sistema_de_pagos.TextBox3.Value = ""
Sistema_de_pagos.TextBox4.Value = ""
Sistema_de_pagos.TextBox5.Value = ""
Sistema_de_pagos.TextBox6.Value = ""

End Sub

Private Sub REGISTRAR_Click()


If TextBox1 = "" Or TextBox2 = "" Or TextBox3 = "" Or TextBox4 = "" Or TextBox5 =
"" Or TextBox6 = "" Then
MsgBox "Cuidado! Faltan campos por llenar", vbInformation, "Error de captura"
Else
Range("B" & Cells.Rows.Count).End(xlUp).Offset(1).Select
ActiveCell = TextBox1.Value
ActiveCell.Offset(0, 1) = TextBox2.Value
ActiveCell.Offset(0, 2) = TextBox3.Value
ActiveCell.Offset(0, 3) = TextBox4.Value
ActiveCell.Offset(0, 4) = TextBox5.Value
ActiveCell.Offset(0, 5) = TextBox6.Value
If OptionButton1.Value = "Verdadero" Then
ActiveCell.Offset(0, 6).FormulaR1C1 = "20"

End If
If OptionButton2.Value = "Verdadero" Then
ActiveCell.Offset(0, 6).FormulaR1C1 = "0"
End If
MsgBox "¡Registro exitoso!", vbOKOnly, "Registro"
TextBox1 = ""
TextBox2 = ""
TextBox3 = ""
TextBox4 = ""
TextBox5 = ""
TextBox6 = ""
End If

End Sub

MODULO PARA QUE APRESCA FORMULARIO


Sub Esquinadoblada2_Haga_clic_en()
Load Sistema_de_pagos
Sistema_de_pagos.Show
End Sub

EVITAR PARPADEO DE GRABADOR DE MACROS


Application.ScreenUpdating = False
Application.ScreenUpdating = True

MARCAR HORA: AVISO


Sub pantallacompleta()
Application.DisplayFullScreen = True
ActiveWindow.DisplayHeadings = False
End Sub

Sub reunion()
Application.OnTime TimeValue("12:17:00"), "AVISO"

End Sub

Sub AVISo()
MsgBox "Faltan 1 minutos para la presentar tu dashboard de resultados"

End Sub

CREAR INVENTARIO CON DOS TABLAS


Sub INVENTARIOS()
'
' INVENTARIOS Macro
'

'
Application.ScreenUpdating = False
Range("E7:E12").Select
Selection.Copy
Sheets("Inventario").Select
Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("E8").Select
Sheets("Acumulacion").Select
Range("E7:E9").Select
Range("E9").Activate
Selection.ClearContents
Range("E11:E12").Select
Selection.ClearContents
Range("E7").Select
Selection.ClearContents
Range("E8").Select
Selection.ClearContents
Range("E9").Select
Selection.ClearContents
Range("E11").Select
Selection.ClearContents
Range("E12").Select
Selection.ClearContents
Application.ScreenUpdating = True
End Sub

FORMULARIO DE GUARDARA…….
MODULO 1
Sub Fecha()
Application.ScreenUpdating = False
Range("D13").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("D13").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D14").Select
Application.CutCopyMode = False
Selection.ClearContents
Application.ScreenUpdating = True
End Sub
Sub Limpiar()
Application.ScreenUpdating = False
Range("D12:D19").Select
Selection.ClearContents
Range("D14").Select
Application.ScreenUpdating = True
End Sub
Sub Consecutivo()
Application.ScreenUpdating = False
Range("D12").Select
ActiveCell.FormulaR1C1 = "=R[-11]C[7]+1"
Range("D12").Select
Selection.Copy
Range("D12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Range("K1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D14").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub Buscar()
Application.ScreenUpdating = False
Range("D13").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(R[-1]C,Registros!R[-6]C[-
2]:R[1048563]C[6],2,0),"""")"
Range("D14").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(R[-2]C,Registros!R[-7]C[-
2]:R[1048562]C[6],3,0),"""")"
Range("D15").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(R[-3]C,Registros!R[-8]C[-
2]:R[1048561]C[6],4,0),"""")"
Range("D16").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(R[-4]C,Registros!R[-9]C[-
2]:R[1048560]C[6],5,0),"""")"
Range("D17").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(R[-5]C,Registros!R[-10]C[-
2]:R[1048559]C[6],6,0),"""")"
Range("D18").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(R[-6]C,Registros!R[-11]C[-
2]:R[1048558]C[6],7,0),"""")"
Range("D19").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(R[-7]C,Registros!R[-12]C[-
2]:R[1048557]C[6],8,0),"""")"
Range("D13:D19").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D12").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub Registrar()
Application.ScreenUpdating = False
Sheets("Registros").Select
Rows("8:8").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
Range("B8").Select
Sheets("Principal").Select
Range("D12:D19").Select
Selection.Copy
Sheets("Registros").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Range("J8").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Activo"
Range("A1").Select
Sheets("Principal").Select
Range("D12").Select
Application.ScreenUpdating = True
End Sub
BOTON GUARDAR
Sub Guardar()
existe = False
For Each D In Range("D14:D16")
If D.Value = "" Then
celdas = celdas & " " & D.Address(False, False)
existe = True
End If
Next
If existe Then
MsgBox "Falta información obligatoria en las celdas : " & celdas 'mensaje
Exit Sub
End If

Set h1 = Sheets("Principal")
Set h2 = Sheets("Registros")
'
If h1.[D14] = "" Then
MsgBox "Falta colocar el código en la celda D14", vbExclamation, "GUARDAR"
Exit Sub
End If

Set b = h2.Columns("D").Find(h1.[D14], lookat:=xlWhole)


If Not b Is Nothing Then
MsgBox "El código ya existe", vbCritical, "GUARDAR"
Exit Sub
End If

Set h1 = Sheets("Principal")
Set h2 = Sheets("Registros")
'
If h1.[D16] = "" Then
MsgBox "Falta colocar el código en la celda D16", vbExclamation, "GUARDAR"
Exit Sub
End If

Set b = h2.Columns("F").Find(h1.[D17], lookat:=xlWhole)


If Not b Is Nothing Then
MsgBox "El n° identidad ya existe", vbCritical, "GUARDAR"
Exit Sub
End If

Consecutivo
Fecha
Registrar

MsgBox "El dato se guardó", vbInformation, "GUARDAR"

Limpiar
End Sub
BOTON ELIMINAR
Sub ELIMINAR()
Dim lista As New Collection
'
Set h1 = Sheets("principal")
Set h2 = Sheets("registros")
'
dato = h1.[D12]
If dato = "" Then
MsgBox "Colocar número de registro"
End If

'
u = h2.Range("B" & Rows.Count).End(xlUp).Row
'
existe = False
For i = 2 To u
If UCase(h2.Cells(i, "B")) = UCase(dato) Then
existe = True
lista.Add i
End If
Next i

Buscar

If existe Then
cf = MsgBox("Desea eliminar el registro con el n° de registro: " & Range("D12"),
vbInformation + vbYesNo, "AVISO")
If cf = vbYes Then

Set r = h2.Columns("B")
Set b = r.Find(h1.[D12], lookat:=xlWhole)

If Not b Is Nothing Then


h2.Cells(b.Row, "J") = "Eliminado"
End If
MsgBox "Registro eliminado con éxito", vbInformation
End If
Else
MsgBox "No se encontró el código: " & Range("D12")
Exit Sub
End If

Limpiar

End Sub

BOTON REMPLAZAR
Sub Reemplazar()

Set h1 = Sheets("principal")
Set h2 = Sheets("registros")

cf = MsgBox("Desea reemplazar el registro?", vbInformation + vbYesNo, "AVISO")


If cf = vbYes Then
If h1.[D12] = "" Then
MsgBox "Colocar número de registro"
Exit Sub
End If
'
If h1.[D13] = "" Then
MsgBox "Falta información en la celda D13"
Exit Sub
End If
'
If h1.[D14] = "" Then
MsgBox "Falta información en la celda D14"
Exit Sub
End If
'
If h1.[D15] = "" Then
MsgBox "Falta información en la celda D15"
Exit Sub
End If
'
If h1.[D16] = "" Then
MsgBox "Falta información en la celda D16"
End If
'
If h1.[D17] = "" Then
MsgBox "Falta información en la celda D17"
End If
'
If h1.[D18] = "" Then
MsgBox "Falta información en la celda D18"
Exit Sub
End If
'
If h1.[D19] = "" Then
MsgBox "Falta información en la celda D19"
Exit Sub
End If

'
Set r = h2.Columns("B")
Set b = r.Find(h1.[D12], lookat:=xlWhole)

If Not b Is Nothing Then

h2.Cells(b.Row, "C") = h1.[D13]


h2.Cells(b.Row, "D") = h1.[D14]
h2.Cells(b.Row, "E") = h1.[D15]
h2.Cells(b.Row, "F") = h1.[D16]
h2.Cells(b.Row, "G") = h1.[D17]
h2.Cells(b.Row, "H") = h1.[D18]
h2.Cells(b.Row, "I") = h1.[D19]

MsgBox "Se ha reemplazado con éxito", vbInformation


Else
MsgBox "El código no existe", vbInformation
Exit Sub
End If

Limpiar

End If
End Sub

ACCES
LOGIN
Private Sub Comando1_Click()
Dim UserLevel As Integer

If IsNull(Me.txtUsuario) Then
MsgBox "Por favor, escriba su Usuario", vbInformation, "Usuario requerido"
Me.txtUsuario.SetFocus
ElseIf IsNull(Me.txtPass) Then
MsgBox "Por favor, ingrese su Contraseña", vbInformation, "Contraseña
requerida"
Me.txtPass.SetFocus
Else
If (IsNull(DLookup("[Usuario]", "Usuarios", "[Usuario] ='" & Me.txtUsuario.Value
&_
"' And Pass = '" & Me.txtPass.Value & "'"))) Then
MsgBox "Usuario y/o Contraseña incorrectos"
Else
UserLevel = DLookup("Nivel_Seguridad", "Usuarios", "Usuario = '" &
Me.txtUsuario.Value & "'")

If UserLevel = 1 Then
DoCmd.Close
MsgBox "Bienvenido!!!", , "Administrador"
Else
DoCmd.OpenForm "Facturar"
MsgBox "Inicie", , "User"
End If
End If
End If
End Sub

MENU
Private Sub Comando10_Click()
Application.Quit
End Sub

También podría gustarte