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
//-->
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
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.
------
Ya sé Excel, pero necesito más.
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.
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.
------
Ya sé Excel, pero necesito más.
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