Excel con formulario para crear una base de datos

5 envíos / 0 nuevos
Último envío
dinkys
Imagen de dinkys
Offline
última acción: Hace 1 semana 3 días
alta: 28/06/2019 - 11:54
Puntos: 115
Excel con formulario para crear una base de datos

Buenos días,

 

Soy un principiante de formularios en excel y necesito crear una base de datos para OF. Si alguien tiene alguna diseñada y me la puede enviar como ejemplo estaría muy agradecido.

 

Un saludo a la comunidad

Etiquetas: 

pacomegia
Imagen de pacomegia
Offline
última acción: Hace 19 horas 16 mins
Nivel 1 - 200 puntosNivel 2 - 500 puntosNivel 3 - 1000 puntosNivel 4 - 2000 puntosNivel 5 - 4000 puntosadministrador
alta: 27/12/2006 - 23:26
Puntos: 10480
vamos a ver

Vamos a ver

-No sé si alguien que tenga una aplicación diseñada la querrá poner aquí gratuitamente, puede ser.

-¿qué es OF?

-Excel no es una base de datos. Si como dices eres princiante con los formularios de Excel, igual aún estás a tiempo de empezar a aprender formularios con Access, que sí es una base de datos de verdad.

 

 

Data Tools Suite
datos y tablas con Excel

dinkys
Imagen de dinkys
Offline
última acción: Hace 1 semana 3 días
alta: 28/06/2019 - 11:54
Puntos: 115
voy viendo

contesto por partes:

Estoy en otros foros en el que hay gente que si que comparte sus cosas (yo mismo) para el bien de la comunidad, pero percibo que este es un foro monipolizado y manipulado ....

Una OF es una Orden de Fabricación

Como soy principiante, comprenderás que access ni lo he tocado, por lo que lo poco que conozco de excel, quiero hacer la base de datos en ella puesto que los otros usuarios que la van a utilizar tampoco conocen access.

De todas formas gracias por haber tenido la delicadeza de contestar.

 

 

pacomegia
Imagen de pacomegia
Offline
última acción: Hace 19 horas 16 mins
Nivel 1 - 200 puntosNivel 2 - 500 puntosNivel 3 - 1000 puntosNivel 4 - 2000 puntosNivel 5 - 4000 puntosadministrador
alta: 27/12/2006 - 23:26
Puntos: 10480
No me malinterpretes, en este

No me malinterpretes, en este foro también se comparte mucho contenido por parte de los usuarios, pero en general suele ser para responder a preguntas o problemas más concretos, no aplicaciones completas.

En cuanto a que el foro está manipulado, en absoluto, aquí sólo se borran los mensajes de spam

En cuanto a que esté monopolizado, tampoco, lo que ocurre es que igual es un foro que no tiene mucho tráfico y por eso parece que siempre contestan los mismos, pero si fuesen cien veces más usuarios sería mucho mejor para todos. 

Sobre el Access, lo decía porque es una aplicación específica de base de datos, y los usuarios no necesitan conocerlo para utilizar una aplicación basada en Access, pero sí es cierto que requiere más esfuerzo de desarrollo y depuración de errores, así que puede ser matar moscas a cañonazos.

 

 

Data Tools Suite
datos y tablas con Excel

dinkys
Imagen de dinkys
Offline
última acción: Hace 1 semana 3 días
alta: 28/06/2019 - 11:54
Puntos: 115
no te mal interpreto

Hola Paco,

No te mal interpreto, solo que hace un tiempo subí el fichero por si a alguien le pudiera valer y veo que no se ha publicado. Dejo el código por si alguien lo necesita

 

''/////////////////////////////////////////////////////////////////////////////////////////////////////////////////
''*****   * xxxxxxx    xxxxx  xxxxx     xxxxx    x      xxxxxx ******************************************//
''***************** x      x     x    x    x    x    x   x      x      ******************************************//
''***************** x      x     x    x     x  x      xxxx   ******************************************//
''***************** x  xxxx      x    x     x   x     x  x      x      ******************************************//
''***************** x   x        x    x    x    x    x   x      x      *************   ******************//
''***************** x    x     xxxxx  xxxxx     xxxxx    xxxxx  xxxxxx ***************** *********************//
'****************************************************************************************************************''
Option Explicit
Public TempForm As Object
Public NewForm As Object
Public a, b, num As String
Public UserRange As Range
Public carga As Range
Public carga2 As Variant
Public cuenta As String
Public opcion As Object
Public oblig, bform As Boolean
Private Sub comprueba()
Dim VBP As Object
If Val(Application.Version) >= 10 Then
    On Error Resume Next
    Set VBP = ActiveWorkbook.VBProject
    If Err.Number <> 0 Then
        MsgBox "Parece que la configuración de seguridad no permite que se ejecute el proceso." _
          & vbCrLf & vbCrLf & "Para cambiar tu configuración de seguridad:" _
          & vbCrLf & vbCrLf & " 1. Selecciona Opciones - Centro de confianza - Configuración." & vbCrLf _
          & " 2. Selecciona Macros y activa la casilla ''Confiar en el acceso al modelo de objetos de proyectos de vba''" & vbCrLf _
          & " 3. Vuelve a intentar ejecutar el proyecto vba.'", _
          vbCritical, "By Riddle"
        End
    End If
End If
End Sub
Sub MakeForm()
comprueba
MsgBox "Bienvenid@ al asistente para generar formularios de forma automatica" & vbCrLf & _
"El formulario creado se guardara en el libro actual por lo que no tendras que volver a generarlo" & vbCrLf & _
"Por favor sigue los pasos que se mostraran", vbInformation, "Asistente para Formularios"
    Set TempForm = ThisWorkbook.VBProject.VBComponents.Add(3)
    With TempForm
        .Properties("Caption") = "Temporary Form"
        .Properties("Width") = 300
    End With
   
campos_formulario
MsgBox "Elije como se comportaran los campos del formulario", vbInformation, "By Riddle"

oblig = False
    VBA.UserForms.Add(TempForm.Name).Show

    End Sub

Private Sub campos_formulario()

Dim t_label, t_com, NewButton, opc As Object
Dim titulo As Range
Dim altura As String
Dim largo As String
Dim m As Double
Dim Nombre As String
altura = 10: largo = 18
On Error GoTo Canceled
Set UserRange = Application.InputBox(Prompt:="Selecciona el rango de los encabezados" & vbCrLf & _
"Estos se utilizaran como nombres de los Label", Title:="By Riddle", Type:=8)
If Range(UserRange.Address(False, False)).Rows.Count > 1 Then MsgBox "Solo puedes seleccionar una fila de encabezados", vbInformation, "By Riddle": GoTo Canceled
For Each titulo In Range(UserRange.Address(False, False))
Nombre = caractesp(titulo.Value)

Set t_label = TempForm.Designer.Controls.Add("forms.Label.1", Nombre)
Set t_com = TempForm.Designer.Controls.Add("forms.Combobox.1", Nombre & "_com")

    With t_label
        .Caption = titulo: .Left = 15: .Top = altura
    End With
    With t_com
        .Left = 102: .Width = 168: .Top = altura: .Value = "Caja de Texto"
    End With
    altura = altura + 18
Next
Set opc = TempForm.Designer.Controls.Add("forms.CheckBox.1", "lopc")
    With opc
        .Caption = "Crear Listbox": .Left = 15: .Top = altura + 18
    End With
 
   altura = altura + 18
   
Set NewButton = TempForm.Designer.Controls.Add("forms.CommandButton.1")
    With NewButton
        .Caption = "Crear Formulario"
        .Left = 114
        .Top = altura + 20
    End With

With TempForm.CodeModule
    m = m + 1: .InsertLines m, "Option Explicit"
    m = m + 1: .InsertLines m, "Public ff as Variant"
    m = m + 1: .InsertLines m, "Private Sub UserForm_Initialize()"
    m = m + 1: .InsertLines m, "Dim combo As Object"
    m = m + 1: .InsertLines m, "For each combo in me.controls"
    m = m + 1: .InsertLines m, "on error resume next"
    m = m + 1: .InsertLines m, "combo.additem ""Caja de Texto"""
    m = m + 1: .InsertLines m, "combo.additem ""Lista Desplegable"""
    m = m + 1: .InsertLines m, "combo.additem ""Cuadro de Busqueda"""
    m = m + 1: .InsertLines m, "combo.additem ""Calendario"""
   
    m = m + 1: .InsertLines m, "next"
    m = m + 1: .InsertLines m, "end sub"
   
    m = m + 1: .InsertLines m, "Private Sub CommandButton1_Click()"
    m = m + 1: .InsertLines m, "Me.hide"
 
    m = m + 1: .InsertLines m, "application.run ""crear_from"""
    m = m + 1: .InsertLines m, "b = 18: num = 1"
    m = m + 1: .InsertLines m, "For Each opcion In Me.Controls"
    m = m + 1: .InsertLines m, "On Error Resume Next"

    m = m + 1: .InsertLines m, "If InStr(1, opcion.Name, ""_com"") Then"
 
    m = m + 1: .InsertLines m, "If opcion.Value = ""Caja de Texto"" Then a = 1"
    m = m + 1: .InsertLines m, "If opcion.Value = ""Lista Desplegable"" Then a = 2"
    m = m + 1: .InsertLines m, "If opcion.Value = ""Cuadro de Busqueda"" Then a = 3"
    m = m + 1: .InsertLines m, "If opcion.Value = ""Calendario"" Then a = 4"
  
    m = m + 1: .InsertLines m, "application.run ""cuerpo_form"""
    m = m + 1: .InsertLines m, "b = b + 20: num = num + 1"
    m = m + 1: .InsertLines m, "End If"
    m = m + 1: .InsertLines m, "Next"
    m = m + 1: .InsertLines m, "If lopc.value = true Then a = 5:application.run ""cuerpo_form"""
    m = m + 1: .InsertLines m, "With NewForm.CodeModule"
    m = m + 1: .InsertLines m, ".InsertLines 1, ""end sub"""
    m = m + 1: .InsertLines m, ".InsertLines 1, cuenta"
    m = m + 1: .InsertLines m, ".InsertLines 1, ""Private Sub llenar"""
    m = m + 1: .InsertLines m, ".InsertLines 1, ""end sub"
    m = m + 1: .InsertLines m, ".InsertLines 1, ""llenar"
   
    m = m + 1: .InsertLines m, ".InsertLines 1, ""On Error Resume Next"
    m = m + 1: .InsertLines m, ".InsertLines 1, ""Private Sub UserForm_Initialize()"
    m = m + 1: .InsertLines m, ".InsertLines 1, ""Public d,ult as string"
    m = m + 1: .InsertLines m, ".InsertLines 1, ""Public busq as range"
     m = m + 1: .InsertLines m, ".InsertLines 1, ""Public c As Object"
     m = m + 1: .InsertLines m, ".InsertLines 1, ""Option Explicit" ''''''''''''
    m = m + 1: .InsertLines m, "End With"

    m = m + 1: .InsertLines m, "MsgBox ""El formulario se a creado y guardado correctamente"",vbinformation,""By Riddle"""
    m = m + 1: .InsertLines m, "VBA.UserForms.Add(NewForm.Name).Show"
  
    m = m + 1: .InsertLines m, "End Sub"
    m = m + 1: .InsertLines m, "Private Sub UserForm_QueryClose(cancel As Integer, CloseMode As Integer)"
    m = m + 1: .InsertLines m, "If CloseMode = 0 Then"
    m = m + 1: .InsertLines m, "MsgBox ""No puedes cerrar esta ventana"", vbInformation, ""By Riddle"""
    m = m + 1: .InsertLines m, "cancel = 1"
    m = m + 1: .InsertLines m, "End If"
    m = m + 1: .InsertLines m, "End Sub"

 End With

TempForm.Properties("Height") = altura + 68
Exit Sub
Canceled:
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(TempForm.Name)
End
End Sub
Private Sub crear_from()
Dim acep, borra As Object
Dim m, cc As Double
Dim cel, cont As Variant
MakeForm2
cc = 1
Set acep = NewForm.Designer.Controls.Add("forms.CommandButton.1", "Aceptar")
Set borra = NewForm.Designer.Controls.Add("forms.CommandButton.1", "Borrar")
With acep
.Width = 72: .Height = 18: .Left = 396: .Top = 18: .Caption = "Aceptar"
 End With
 With borra
.Width = 72: .Height = 18: .Left = 396: .Top = 42: .Caption = "Borrar"
 End With
 With NewForm.CodeModule

m = m + 1: .InsertLines m, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)"
m = m + 1: .InsertLines m, "End"
m = m + 1: .InsertLines m, "End Sub"

m = m + 1: .InsertLines m, "Private Sub Aceptar_Click()"
If oblig = True Then _
m = m + 1: .InsertLines m, "if not Validar(Me)="""" then msgbox ""No puedes dejar espacios vacios"":Exit sub"
m = m + 1: .InsertLines m, "ult= cells(rows.count," & UserRange.Column & ").end(xlup).row+1"
m = m + 1: .InsertLines m, "If Aceptar.caption=""Modificar"" then ult = d"
For Each cel In Range(UserRange.Address(0, 0))
cont = "control" & cc

m = m + 1: .InsertLines m, "If IsNumeric(" & cont & ") then cells(ult," & cel.Column & ")=int(" & cont & _
") else if isdate(" & cont & ") then cells(ult," & cel.Column & ")=cdate(" & cont _
& "):cells(ult," & cel.Column & ").NumberFormat = ""m/d/yyyy"" else cells(ult," & cel.Column & ")=" & cont

cc = cc + 1
Next
m = m + 1: .InsertLines m, "for each c in me.controls"
m = m + 1: .InsertLines m, "on error resume next"
m = m + 1: .InsertLines m, "c.value=Empty"
m = m + 1: .InsertLines m, "next"
m = m + 1: .InsertLines m, "llenar"
m = m + 1: .InsertLines m, "Aceptar.caption=""Aceptar"""
m = m + 1: .InsertLines m, "End Sub"

m = m + 1: .InsertLines m, "Private Sub Borrar_Click()"
m = m + 1: .InsertLines m, "on error resume next"
m = m + 1: .InsertLines m, "Cells(busq.row, 1).EntireRow.Delete"
m = m + 1: .InsertLines m, "for each c in me.controls"
m = m + 1: .InsertLines m, "on error resume next"
m = m + 1: .InsertLines m, "c.value=Empty"
m = m + 1: .InsertLines m, "next"
m = m + 1: .InsertLines m, "Aceptar.caption=""Aceptar"""
m = m + 1: .InsertLines m, "End Sub"

End With
End Sub
Private Sub MakeForm2()
    Dim nom As String
    Dim TextLocation As Integer
    Dim t_label As Control, titulo As Range, altura As String
  
    Set NewForm = ThisWorkbook.VBProject.VBComponents.Add(3)
    On Error Resume Next
    nom = InputBox("Elija el titulo del Formulario", "By Riddle", "By Riddle")
    With NewForm
        .Properties("Caption") = nom
        .Properties("Width") = 500

    End With
    altura = 18
   
    For Each titulo In Range(UserRange.Address(False, False))
Set t_label = NewForm.Designer.Controls.Add("forms.Label.1", caractesp(titulo.Value))
With t_label
        .Caption = titulo: .Left = 15: .Top = altura
    End With
altura = altura + 20
Next
NewForm.Properties("Height") = altura + 64
 If MsgBox("Quieres que sea obligatorio llenar todos los campos del formulario", vbQuestion + vbYesNo, "By Riddle") = vbYes Then _
 oblig = True
 If MsgBox("Quieres crear un botón de acceso rapido al formulario creado?", vbQuestion + vbYesNo, "By Riddle") = vbYes Then _
 insert_one

    End Sub
Private Sub cuerpo_form()
Dim tut, ctrl, busca As Object
Dim tipo As String
Dim m, sa As Double
Dim colum As Double
Dim col As Variant
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(TempForm.Name)
m = 3
colum = UserRange.Column

If a = 1 Then tipo = "Textbox"
If a = 2 Then tipo = "Combobox"
If a = 3 Then tipo = "Textbox"
If a <= 3 Then

Set ctrl = NewForm.Designer.Controls.Add("forms." & tipo & ".1")
If a = 3 Then
Set busca = NewForm.Designer.Controls.Add("forms.CommandButton.1", "Buscar" & num)
With NewForm.CodeModule
m = m + 1: .InsertLines m, "Private Sub Buscar" & num & "_Click()"
m = m + 1: .InsertLines m, "if Control" & num & "="""" then msgbox""Debes escribir algo para buscar"": Exit sub"
m = m + 1: .InsertLines m, "on error resume next"
m = m + 1: .InsertLines m, "set busq= activesheet.columns(" & Range(UserRange.Address).Offset(0, num - 1).Column & ").find(" & "Control" & num & ",lookat:=xlwhole)"
m = m + 1: .InsertLines m, "if busq is nothing then msgbox ""No se encontro el elemento buscado"":Exit sub"
m = m + 1: .InsertLines m, "d=busq.row"

For Each col In Range(UserRange.Address(0, 0))
sa = sa + 1
m = m + 1: .InsertLines m, "Control" & sa & "=cells(d," & col.Column & ") "
Next
m = m + 1: .InsertLines m, "Aceptar.caption=""Modificar"""
m = m + 1: .InsertLines m, "end sub"

End With
End If
If a = 2 Then

If MsgBox("Quieres que el rango de " & VBA.Left(opcion.Name, InStr(opcion.Name, "_") - 1) & " sea fijo?" & vbCrLf & _
"Si elijes no las listas se cargaran con rangos dinamicos", vbQuestion + vbYesNo, "By Riddle") = vbNo Then
v:
Set carga = Application.InputBox(Prompt:="Selecciona la primera celda de datos a cargar", Title:="By Riddle", Type:=8)
If Range(carga.Address(False, False)).Rows.Count > 1 Or _
Range(carga.Address(False, False)).Columns.Count > 1 Then MsgBox "Solo puedes seleccionar la primera celda de la lista", vbInformation, "By Riddle": GoTo v
carga2 = "Sheets(" & """" & carga.Parent.Name & """" & ").Range(" & """" & carga.Address(0, 0) & """" & ").End(xlDown).Address(0, 0)"
carga2 = carga.Parent.Name & "!" & carga.Address(0, 0) & ":"" & " & carga2
carga2 = "Control" & num & ".RowSource =" & """" & carga2

Else
w:
Set carga = Application.InputBox(Prompt:="Selecciona el rango de la lista", Title:="By Riddle", Type:=8)
If Range(carga.Address(False, False)).Columns.Count > 1 Then MsgBox "Solo puedes seleccionar 1 columna para la lista", vbInformation, "By Riddle": GoTo w
carga2 = carga.Parent.Name & "!" & carga.Address(False, False)
carga2 = "Control" & num & ".RowSource =" & """" & carga2 & """"

End If

With NewForm.CodeModule
     m = m + 1: .InsertLines m, "Private sub cargaControl" & num & "()"
     m = m + 1: .InsertLines m, carga2
     m = m + 1: .InsertLines m, "end sub"
   
cuenta = "cargaControl" & num & vbCrLf & cuenta
End With
End If
End If

If a = 4 Then
If Not Application.Version = 14# Then MsgBox "Es probable que el control calendario no funcione correctamente en esta versión de excel" & vbCrLf & _
    "Para que funcione correctamente debes instalar el complemento MSCOMCT2.OCX"
Set ctrl = NewForm.Designer.Controls.Add("MSComCtl2.DTPicker")

 End If
On Error Resume Next
 If a <= 4 Then
 With busca
 .Caption = "Buscar " & VBA.Left(opcion.Name, InStr(opcion.Name, "_") - 1): .Height = 20: .Left = 282: .Top = b
 End With
 With ctrl
 .Name = "Control" & num: .Width = 168: .Height = 18: .Left = 102: .Top = b
 End With
 End If

 If a = 5 Then
 Set ctrl = NewForm.Designer.Controls.Add("forms.listbox.1")
 
 With ctrl
 .Name = "Control" & num: .Width = 477: .Height = 179: .Left = 10: .Top = b
 End With
 NewForm.Properties("Height") = NewForm.Properties("Height") + 145

 Set carga = UserRange
If Range(carga.Address(False, False)).Rows.Count > 1 Then MsgBox "Solo puedes seleccionar una fila de encabezados", vbInformation, "By Riddle" ': GoTo v
carga2 = "Sheets(" & """" & carga.Parent.Name & """" & ").Range(" & """" & carga.Address(0, 0) & """" & ").End(xlDown).Address(0, 0)"
carga2 = carga.Parent.Name & "!" & carga.Offset(1, 0).Address(0, 0) & ":"" & " & carga2
carga2 = "Control" & num & ".RowSource =" & """" & carga2
 
With NewForm.CodeModule
    m = m + 1: .InsertLines m, "Private sub cargaControl" & num & "()"
    m = m + 1: .InsertLines m, carga2
    m = m + 1: .InsertLines m, "Control" & num & ".columncount=" & carga.Columns.Count
    m = m + 1: .InsertLines m, "Control" & num & ".columnheads= true"
    m = m + 1: .InsertLines m, "end sub"

cuenta = "cargaControl" & num & vbCrLf & cuenta

m = m + 1: .InsertLines m, "Private Sub Control" & num & "_DblClick(ByVal Cancel As MSForms.ReturnBoolean)"
m = m + 1: .InsertLines m, "on error resume next"
m = m + 1: .InsertLines m, "set busq= activesheet.columns(" & Range(UserRange.Address).Column & ").find(" & "Control" & num & ",lookat:=xlwhole)"
m = m + 1: .InsertLines m, "if busq is nothing then Exit sub"
m = m + 1: .InsertLines m, "d=busq.row"

For Each col In Range(UserRange.Address(0, 0))
sa = sa + 1
m = m + 1: .InsertLines m, "Control" & sa & "=cells(d," & col.Column & ") "
Next
m = m + 1: .InsertLines m, "Aceptar.caption=""Modificar"""
m = m + 1: .InsertLines m, "End Sub"
End With
 End If
End Sub
Function validar(form As Object) As String
Dim txt As Control, x As String
For Each txt In form.Controls
If TypeName(txt) = "TextBox" Or TypeName(txt) = "ComboBox" Then _
If txt.Value = "" Then x = x & vbCrLf & txt.Name: txt.BackColor = vbYellow Else txt.BackColor = vbWhite
Next
validar = x
End Function

Private Sub insert_one()
Dim hoja As Object
Dim m As Double
Dim bt As Range
On Error Resume Next
Set bt = Application.InputBox(Prompt:="Selecciona donde se creara el botón para llamar el formulario", Title:="By JR", Type:=8)

Set hoja = ThisWorkbook.VBProject.VBComponents(bt.Parent.Name)
    With Sheets(bt.Parent.Name).OLEObjects.Add(classtype:="Forms.CommandButton.1", _
         Top:=bt.Top, Left:=bt.Left, _
         Height:=bt.Height * 2, Width:=bt.Width * 2)
         .Object.Caption = "Formulario"
         .Name = "boton" & NewForm.Name
     End With
    
     With hoja.CodeModule
     m = m + 1: .InsertLines m, "Private Sub boton" & NewForm.Name & "_Click()"
     m = m + 1: .InsertLines m, NewForm.Name & ".show"
     m = m + 1: .InsertLines m, "end sub"
     End With
    
End Sub

Function caractesp(s As String)
Dim cadena As Variant
Dim i As Double
cadena = Array(" ", "-", "_", ",", "{", "}", "[", "]", "!", "#", "$", "%", "&", "/", "(", ")", "=", "?", "¡", "'", "¿", "|", "*", "+", "¨", "´", ":", ".", ";", "<", ">")
For i = 0 To UBound(cadena)
s = Replace(s, cadena(i), "")
Next
caractesp = s
End Function