1. Entre a Excel
2. Guarde en su carpeta el libro de calculo con el nombre MiFormulario1104 (Sin espacios) y en tipo elija Libro de Excel habilitado para Macros y haga clic en Guardar
3. Cambie el nombre a la Hoja1 por BD. En la celda B3, digite CODIGO. En la celda C3, digite APELLIDOS. En la celda D3, digite NOMBRES. En la celda E3, digite EDAD y en la celda F3, digite SEXO. En la celda G3, digite DIRECCIONy en la celda H3, digite CELULAR y en la celda I3 digite E-MAIL
4. Seleccione los encabezados y presione al mismo tiempo las teclas CTRL y T
Y en esta ventana
hacemos clic en el Check , La tabla tiene encabezados y hacemos clic en Aceptar
6. Luego en la pestaña Diseño de tabla elegimos un Estilo de Tabla.
7. Le damos un nombre a la tabla, para ello haz clic en cualquier parte de la tabla, por ejemplo hacer clic en la celda c3. Luego vamos a Diseño de tabla y en la parte Izquierda superior donde dice nombre de la tabla escribimos ESTUDIANTES
8. . Ahora vamos a la pestaña Vista y desactivamos el Check Lineas de cuadrícula, para que no se vean las cuadrícula
9. En la celda F2 ponemos una forma de rectángulo con las esquinas redondeadas y le agregamos el texto AGREGAR y el color que queramos
En la celda B2 escriba la fórmula =MAX(ESTUDIANTES[CODIGO])+1
Luego ingrese un registro en la tabla
la hoja de excel debe quedar con la siguiente apariencia:
10. Vamos a la pestaña Programador y damos clic en Visual Basic
11. Damos clic en Insertar e insertamos un UserForm que tendrá la siguiente apariencia
le damos nombre a los botones de comando, poniéndoles la palabra Bt_ (Bt raya al piso) y seguido el nombre que se ve en el botón. Es decir el botón Modificar se llamará Bt_Modificar y así con los otros botones
El cuadro de lista en su propiedad Nombre le escribimos Lista y en su propiedad ColumnsWidths escriba: 40 pt;49,95 pt;49,95 pt;40 pt;30 pt;70 pt;49,95 pt;49,95 pt
para darle ancho a las columnas de la lista. En su propiedad ColumCount en 8
La caja de texto que está arriba del cuadro de lista en su propiedad nombre le pondremos txt_busqueda
La caja de texto txt_codigo debe tener su propiedad enabled en False
Las cajas de texto de Codigo, Nombres, Apellidos, Genero, Decreto, escalafón y Area de desempeño se les pondrá en su nombre la palabra txt_ (Txt raya al piso) seguido del nombre de su etiqueta. (txt_codigo, txt_nombres, txt_apellidos, txt_edad, txt_sexo, txt_direccion, txt_celular y txt_email).
Seleccionamos el formulario y le cambiamos el nombre en su propiedad Name escribimos miformulario
Ahora escribimos el siguiente código
Option Explicit
Private Sub bt_modificar_Click()
Dim ws As Worksheet
Dim ultimaFila As Long
Dim fila As Long
Dim codigo As String
Dim encontrado As Boolean
Set ws = ThisWorkbook.Worksheets("bd")
'========================================
' VERIFICAR SELECCIÓN
'========================================
If Me.Lista.ListIndex = -1 Then
MsgBox "DEBE SELECCIONAR UN ESTUDIANTE", _
vbExclamation, "Modificar"
Exit Sub
End If
'========================================
' TOMAR CÓDIGO DEL LISTBOX
'========================================
codigo = Trim(CStr( _
Me.Lista.List(Me.Lista.ListIndex, 0)))
'========================================
' ÚLTIMA FILA
'========================================
ultimaFila = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
encontrado = False
'========================================
' BUSCAR CÓDIGO
'========================================
For fila = 4 To ultimaFila
If Trim(CStr(ws.Cells(fila, 2).Value)) = codigo Then
encontrado = True
'================================
' MODIFICAR
'================================
ws.Cells(fila, 3).Value = _
UCase(Me.txt_nombres.Value)
ws.Cells(fila, 4).Value = _
UCase(Me.txt_apellidos.Value)
ws.Cells(fila, 5).Value = _
Me.txt_edad.Value
ws.Cells(fila, 6).Value = _
UCase(Me.txt_sexo.Value)
ws.Cells(fila, 7).Value = _
UCase(Me.txt_direccion.Value)
ws.Cells(fila, 8).Value = _
Me.txt_celular.Value
ws.Cells(fila, 9).Value = _
UCase(Me.txt_email.Value)
Exit For
End If
Next fila
'========================================
' SI NO ENCUENTRA
'========================================
If encontrado = False Then
MsgBox "NO SE ENCONTRÓ EL ESTUDIANTE CON CÓDIGO: " & codigo, _
vbExclamation, "Modificar"
Exit Sub
End If
'========================================
' ACTUALIZAR LISTA
'========================================
CargarLista
MsgBox "LOS DATOS FUERON MODIFICADOS CORRECTAMENTE", _
vbInformation, "Modificar"
'========================================
' LIMPIAR
'========================================
Me.txt_nombres.Value = ""
Me.txt_apellidos.Value = ""
Me.txt_edad.Value = ""
Me.txt_sexo.Value = ""
Me.txt_direccion.Value = ""
Me.txt_celular.Value = ""
Me.txt_email.Value = ""
Me.txt_busqueda.Value = ""
Me.bt_agregar.Enabled = True
Me.bt_modificar.Enabled = False
'Siguiente código
If ultimaFila >= 4 Then
Me.txt_codigo.Value = _
Application.WorksheetFunction.Max( _
ws.Range("B4:B" & ultimaFila)) + 1
Else
Me.txt_codigo.Value = 1
End If
End Sub
Private Sub bt_salir_Click()
End
End Sub
'==========================================================
' AL ACTIVAR EL FORMULARIO
'==========================================================
Private Sub UserForm_Activate()
Me.txt_codigo.Enabled = False
Me.bt_agregar.Enabled = True
Me.bt_modificar.Enabled = False
Me.Height = 353
CargarLista
End Sub
'==========================================================
' PROCEDIMIENTO PARA CARGAR TODOS LOS ESTUDIANTES
'==========================================================
Private Sub CargarLista()
Dim ws As Worksheet
Dim ultimaFila As Long
Dim fila As Long
Set ws = ThisWorkbook.Worksheets("bd")
With Me.Lista
.RowSource = ""
.Clear
.ColumnCount = 8
.ColumnHeads = False
End With
'Última fila usando NOMBRES, columna C
ultimaFila = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
'Cargar solamente estudiantes
If ultimaFila >= 4 Then
For fila = 4 To ultimaFila
If Trim(ws.Cells(fila, 3).Value) <> "" Then
With Me.Lista
.AddItem ws.Cells(fila, 2).Value
.List(.ListCount - 1, 1) = ws.Cells(fila, 3).Value
.List(.ListCount - 1, 2) = ws.Cells(fila, 4).Value
.List(.ListCount - 1, 3) = ws.Cells(fila, 5).Value
.List(.ListCount - 1, 4) = ws.Cells(fila, 6).Value
.List(.ListCount - 1, 5) = ws.Cells(fila, 7).Value
.List(.ListCount - 1, 6) = ws.Cells(fila, 8).Value
.List(.ListCount - 1, 7) = ws.Cells(fila, 9).Value
End With
End If
Next fila
End If
End Sub
'==========================================================
' BOTÓN NUEVO
'==========================================================
Private Sub bt_nuevo_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("bd")
Me.Height = 353
'Obtener nuevo código desde B2
Me.txt_codigo.Value = ws.Range("B2").Value
'Limpiar campos
Me.txt_nombres.Value = ""
Me.txt_apellidos.Value = ""
Me.txt_edad.Value = ""
Me.txt_sexo.Value = ""
Me.txt_direccion.Value = ""
Me.txt_celular.Value = ""
Me.txt_email.Value = ""
'Activar agregar
Me.bt_agregar.Enabled = True
Me.bt_modificar.Enabled = False
Me.txt_nombres.SetFocus
End Sub
Private Sub bt_agregar_Click()
Dim ws As Worksheet
Dim ultimaFila As Long
Dim nuevaFila As Long
Dim nuevoCodigo As Long
Dim nombrev As String
Dim apellidov As String
Dim fila As Long
Dim existe As Boolean
Set ws = ThisWorkbook.Worksheets("bd")
nombrev = Trim(Me.txt_nombres.Value)
apellidov = Trim(Me.txt_apellidos.Value)
'========================================
' VALIDAR NOMBRE Y APELLIDO
'========================================
If nombrev = "" Or apellidov = "" Then
MsgBox "INGRESE EL NOMBRE Y EL APELLIDO", _
vbExclamation, "Datos incompletos"
Exit Sub
End If
'========================================
' BUSCAR DUPLICADOS
'========================================
ultimaFila = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
existe = False
If ultimaFila >= 4 Then
For fila = 4 To ultimaFila
If UCase(Trim(CStr(ws.Cells(fila, 3).Value))) = _
UCase(nombrev) And _
UCase(Trim(CStr(ws.Cells(fila, 4).Value))) = _
UCase(apellidov) Then
existe = True
Exit For
End If
Next fila
End If
If existe = True Then
MsgBox "EL ESTUDIANTE YA EXISTE", _
vbExclamation, "Registro duplicado"
Exit Sub
End If
'========================================
' BUSCAR ÚLTIMA FILA REAL
'========================================
ultimaFila = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
If ultimaFila < 4 Then
nuevaFila = 4
Else
nuevaFila = ultimaFila + 1
End If
'========================================
' GENERAR CÓDIGO
'========================================
If nuevaFila = 4 Then
nuevoCodigo = 1
Else
nuevoCodigo = Application.WorksheetFunction.Max( _
ws.Range("B4:B" & ultimaFila)) + 1
End If
'========================================
' GUARDAR DATOS
'========================================
With ws
.Cells(nuevaFila, 2).Value = nuevoCodigo
.Cells(nuevaFila, 3).Value = UCase(nombrev)
.Cells(nuevaFila, 4).Value = UCase(apellidov)
.Cells(nuevaFila, 5).Value = Me.txt_edad.Value
.Cells(nuevaFila, 6).Value = UCase(Me.txt_sexo.Value)
.Cells(nuevaFila, 7).Value = UCase(Me.txt_direccion.Value)
.Cells(nuevaFila, 8).Value = Me.txt_celular.Value
.Cells(nuevaFila, 9).Value = UCase(Me.txt_email.Value)
End With
'========================================
' ACTUALIZAR LISTA
'========================================
CargarLista
MsgBox "ESTUDIANTE AGREGADO CORRECTAMENTE" & _
vbCrLf & _
"Código: " & nuevoCodigo, _
vbInformation, "Registro"
'========================================
' LIMPIAR
'========================================
Me.txt_nombres.Value = ""
Me.txt_apellidos.Value = ""
Me.txt_edad.Value = ""
Me.txt_sexo.Value = ""
Me.txt_direccion.Value = ""
Me.txt_celular.Value = ""
Me.txt_email.Value = ""
'Siguiente código
Me.txt_codigo.Value = nuevoCodigo + 1
End Sub
'==========================================================
' BOTÓN EDITAR
'==========================================================
Private Sub bt_editar_Click()
If Me.Lista.ListIndex = -1 Then
MsgBox "SELECCIONE UN ESTUDIANTE DE LA LISTA", _
vbExclamation, "Editar"
Exit Sub
End If
'Cargar los datos del estudiante seleccionado
Me.txt_codigo.Value = Me.Lista.List(Me.Lista.ListIndex, 0)
Me.txt_nombres.Value = Me.Lista.List(Me.Lista.ListIndex, 1)
Me.txt_apellidos.Value = Me.Lista.List(Me.Lista.ListIndex, 2)
Me.txt_edad.Value = Me.Lista.List(Me.Lista.ListIndex, 3)
Me.txt_sexo.Value = Me.Lista.List(Me.Lista.ListIndex, 4)
Me.txt_direccion.Value = Me.Lista.List(Me.Lista.ListIndex, 5)
Me.txt_celular.Value = Me.Lista.List(Me.Lista.ListIndex, 6)
Me.txt_email.Value = Me.Lista.List(Me.Lista.ListIndex, 7)
'Preparar modificación
Me.bt_agregar.Enabled = False
Me.bt_modificar.Enabled = True
Me.txt_codigo.Enabled = False
End Sub
Private Sub bt_eliminar_Click()
Dim ws As Worksheet
Dim ultimaFila As Long
Dim fila As Long
Dim codigo As String
Dim nombre As String
Dim apellido As String
Dim respuesta As VbMsgBoxResult
Dim encontrado As Boolean
Set ws = ThisWorkbook.Worksheets("bd")
'==========================================
' VERIFICAR QUE HAYA UN ESTUDIANTE SELECCIONADO
'==========================================
If Me.Lista.ListIndex = -1 Then
MsgBox "SELECCIONE UN ESTUDIANTE DE LA LISTA", _
vbExclamation, "Eliminar"
Exit Sub
End If
'==========================================
' OBTENER DATOS DEL LISTBOX
'==========================================
codigo = Trim(CStr(Me.Lista.List(Me.Lista.ListIndex, 0)))
nombre = CStr(Me.Lista.List(Me.Lista.ListIndex, 1))
apellido = CStr(Me.Lista.List(Me.Lista.ListIndex, 2))
'==========================================
' CONFIRMAR ELIMINACIÓN
'==========================================
respuesta = MsgBox( _
"¿ESTÁ SEGURO DE ELIMINAR AL ESTUDIANTE?" & _
vbCrLf & vbCrLf & _
"Código: " & codigo & _
vbCrLf & _
"Nombre: " & nombre & " " & apellido, _
vbYesNo + vbQuestion, _
"Confirmar eliminación")
If respuesta <> vbYes Then Exit Sub
'==========================================
' BUSCAR ÚLTIMA FILA
'==========================================
ultimaFila = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
encontrado = False
'==========================================
' BUSCAR EL CÓDIGO DESDE LA FILA 4
'==========================================
For fila = 4 To ultimaFila
If Trim(CStr(ws.Cells(fila, 2).Value)) = codigo Then
'Eliminar solamente esa fila
ws.Rows(fila).Delete
encontrado = True
Exit For
End If
Next fila
'==========================================
' VERIFICAR SI SE ELIMINÓ
'==========================================
If encontrado = False Then
MsgBox "NO SE ENCONTRÓ EL ESTUDIANTE CON CÓDIGO: " & codigo, _
vbExclamation, "Eliminar"
Exit Sub
End If
'==========================================
' ACTUALIZAR LISTA
'==========================================
CargarLista
'==========================================
' LIMPIAR CAMPOS
'==========================================
Me.txt_codigo.Value = ""
Me.txt_nombres.Value = ""
Me.txt_apellidos.Value = ""
Me.txt_edad.Value = ""
Me.txt_sexo.Value = ""
Me.txt_direccion.Value = ""
Me.txt_celular.Value = ""
Me.txt_email.Value = ""
Me.txt_busqueda.Value = ""
'==========================================
' OBTENER NUEVO CÓDIGO
'==========================================
If ws.Cells(ws.Rows.Count, "B").End(xlUp).Row >= 4 Then
Me.txt_codigo.Value = _
Application.WorksheetFunction.Max( _
ws.Range("B4:B" & _
ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)) + 1
Else
Me.txt_codigo.Value = 1
End If
'==========================================
' CONFIGURAR BOTONES
'==========================================
Me.bt_agregar.Enabled = True
Me.bt_modificar.Enabled = False
MsgBox "EL ESTUDIANTE FUE ELIMINADO CORRECTAMENTE", _
vbInformation, "Eliminar"
End Sub
'==========================================================
' BOTÓN BUSCAR
'==========================================================
Private Sub bt_busqueda_Click()
Dim ws As Worksheet
Dim ultimaFila As Long
Dim fila As Long
Dim textoBuscar As String
Dim encontrado As Boolean
Set ws = ThisWorkbook.Worksheets("bd")
textoBuscar = Trim(Me.txt_busqueda.Value)
'------------------------------------------
' Verificar búsqueda
'------------------------------------------
If textoBuscar = "" Then
MsgBox "ESCRIBA UN NOMBRE PARA REALIZAR LA BÚSQUEDA", _
vbExclamation, "Búsqueda"
Exit Sub
End If
ultimaFila = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'------------------------------------------
' Limpiar ListBox
'------------------------------------------
Me.Lista.RowSource = ""
Me.Lista.Clear
Me.Lista.ColumnCount = 8
encontrado = False
'------------------------------------------
' Buscar por nombres
'------------------------------------------
For fila = 4 To ultimaFila
If UCase(CStr(ws.Cells(fila, 3).Value)) _
Like "*" & UCase(textoBuscar) & "*" Then
encontrado = True
With Me.Lista
.AddItem ws.Cells(fila, 2).Value
.List(.ListCount - 1, 1) = ws.Cells(fila, 3).Value
.List(.ListCount - 1, 2) = ws.Cells(fila, 4).Value
.List(.ListCount - 1, 3) = ws.Cells(fila, 5).Value
.List(.ListCount - 1, 4) = ws.Cells(fila, 6).Value
.List(.ListCount - 1, 5) = ws.Cells(fila, 7).Value
.List(.ListCount - 1, 6) = ws.Cells(fila, 8).Value
.List(.ListCount - 1, 7) = ws.Cells(fila, 9).Value
End With
End If
Next fila
'------------------------------------------
' Resultado
'------------------------------------------
If encontrado = False Then
MsgBox "EL ESTUDIANTE NO EXISTE", _
vbInformation, "Resultado de búsqueda"
End If
End Sub
'==========================================================
' CLICK EN EL LISTBOX
'==========================================================
Private Sub lista_Click()
Dim indice As Long
If Me.Lista.ListIndex = -1 Then Exit Sub
indice = Me.Lista.ListIndex
'Código
Me.txt_codigo.Value = Me.Lista.List(indice, 0)
'Nombres
Me.txt_nombres.Value = Me.Lista.List(indice, 1)
'Apellidos
Me.txt_apellidos.Value = Me.Lista.List(indice, 2)
'Edad
Me.txt_edad.Value = Me.Lista.List(indice, 3)
'Sexo
Me.txt_sexo.Value = Me.Lista.List(indice, 4)
'Dirección
Me.txt_direccion.Value = Me.Lista.List(indice, 5)
'Celular
Me.txt_celular.Value = Me.Lista.List(indice, 6)
Me.txt_email.Value = Me.Lista.List(indice, 7)
'Botones
Me.bt_agregar.Enabled = False
Me.bt_modificar.Enabled = True
End Sub
ahora hacemos clic en Insertar e insertamos un módulo. Escribimos en ese módulo lo siguiente:
Sub llamar()
miformulario.Show
End Sub
Ahora vamos al libro de excel y seleccionamos La forma que dice Agregar y presionamos botón derecho, luego hacemos clic en Asignar Macro y hacemos clic en llamar.