Anónimo
Función que extraiga constantes de un excel externo
Buenos días
He hecho una fórmula de 300 casos(como base de datos interna). Pero piden que la base de datos sea externa
El problema es que la fórmula necesita unas constantes para cada caso. Pero se requiere que esas constantes estén en un archivo modificable excel en un disco externo. Bueno lo he intentado utilizando el código de un macro que sacaba valores de otra tabla, pero en el momento que selecciona otra celda la función se apaga (lo cual es normal, creo, ya que la función reside en esa celda del excel)
¿Entonces es por si sabría como extraer esa información sin que la función se apague?
También me han comentado que existe la programación de clases (o variables) es decir programar una variable como puede ser "VARIANT" y que esta haga lo de extraer el dato. No se si seria posible, si usted conoce del tema y pudiera orientarme..
MUCHAS GRACIAS, si me pudiera ayudar me salvaría la salud y el pelo(ya que me encuentro en un callejón sin salida).
He hecho una fórmula de 300 casos(como base de datos interna). Pero piden que la base de datos sea externa
El problema es que la fórmula necesita unas constantes para cada caso. Pero se requiere que esas constantes estén en un archivo modificable excel en un disco externo. Bueno lo he intentado utilizando el código de un macro que sacaba valores de otra tabla, pero en el momento que selecciona otra celda la función se apaga (lo cual es normal, creo, ya que la función reside en esa celda del excel)
¿Entonces es por si sabría como extraer esa información sin que la función se apague?
También me han comentado que existe la programación de clases (o variables) es decir programar una variable como puede ser "VARIANT" y que esta haga lo de extraer el dato. No se si seria posible, si usted conoce del tema y pudiera orientarme..
MUCHAS GRACIAS, si me pudiera ayudar me salvaría la salud y el pelo(ya que me encuentro en un callejón sin salida).
Respuesta de vorkosigan
1
¿Puedes poner un ejemplo de esa fórmula, y de las constantes?
Function perdidapresion(Name As string, Dendidad As Single, velocidad As single,viscosidad As single)
La funcion que he hecho es algo asi( te pongo 3 casos)
Dim a As Single;Dim b As Single, Dim w As Single,d As Single;Beta As Single
Select Case Name
Case "Q-20/20"
a=6.98
b=8.63
perdidapresion=((((a+(b*viscosidad)/(densidad*velocidad*10^(-6))))*densidad*((velocidad^2)/2)))/10^(5))
Case "Q-25/25"
a=5.211
b=6.23
perdidapresion=((((a+(b*viscosidad)/(densidad*velocidad*10^(-6))))*densidad*((velocidad^2)/2)))/10^(5))
Case "Q-32/28"
w=32
d=28
Beta=((w/(d+w))^2
perdida de presion=(((1-Beta)/(Beta^2))*(0.72+((49*Beta*viscosidad)/(densidad*velocidad*d*10^(-6)))))*densidad((velocidad^2)/2)/10^(5)
Esto seria para 300 casos entonces lo que intento es de conseguir que la función busque en una base de datos externa(excel) que la abra saque los datos de a y b para el nombre de malla Q-20/20 y si no hubiera coja w y de y calcule la perdida de presión.
Mi problema es conseguir la información para a y b he probado con...
workbook.Open filename:="c:\....."
worksheets(1).Activate
Columns("A:A").Activate
Selection.find( What=uInput,After:=ActiveCell,LookIn:=xlformulas,Lookat:=x1Part_
, SearchOrder:=x1byRows,SearchDirection:=x1Next,_ MatchCase:=False,Searchformat:=False).activate
mfila=ActiveCell.Row
activeoffset(0,4)=a
lo he copiado a mano puede haber fallos al pasarlo. Pero no funciona el metodo
Gracias por su ayuda
La funcion que he hecho es algo asi( te pongo 3 casos)
Dim a As Single;Dim b As Single, Dim w As Single,d As Single;Beta As Single
Select Case Name
Case "Q-20/20"
a=6.98
b=8.63
perdidapresion=((((a+(b*viscosidad)/(densidad*velocidad*10^(-6))))*densidad*((velocidad^2)/2)))/10^(5))
Case "Q-25/25"
a=5.211
b=6.23
perdidapresion=((((a+(b*viscosidad)/(densidad*velocidad*10^(-6))))*densidad*((velocidad^2)/2)))/10^(5))
Case "Q-32/28"
w=32
d=28
Beta=((w/(d+w))^2
perdida de presion=(((1-Beta)/(Beta^2))*(0.72+((49*Beta*viscosidad)/(densidad*velocidad*d*10^(-6)))))*densidad((velocidad^2)/2)/10^(5)
Esto seria para 300 casos entonces lo que intento es de conseguir que la función busque en una base de datos externa(excel) que la abra saque los datos de a y b para el nombre de malla Q-20/20 y si no hubiera coja w y de y calcule la perdida de presión.
Mi problema es conseguir la información para a y b he probado con...
workbook.Open filename:="c:\....."
worksheets(1).Activate
Columns("A:A").Activate
Selection.find( What=uInput,After:=ActiveCell,LookIn:=xlformulas,Lookat:=x1Part_
, SearchOrder:=x1byRows,SearchDirection:=x1Next,_ MatchCase:=False,Searchformat:=False).activate
mfila=ActiveCell.Row
activeoffset(0,4)=a
lo he copiado a mano puede haber fallos al pasarlo. Pero no funciona el metodo
Gracias por su ayuda
Prueba este código:
Function PerdidaPresion(ByVal Densidad As Single, ByVal velocidad As Single, ByVal viscosidad As Single, ByVal Parametro As String) As Double
Dim RutaActual, NombreFichero, fic As String
Dim FilaInicial, FilaFinal, fil As Integer
Dim a, b, w, d As Single
Dim solucion, Beta As Double
'calculo el nombre de la base de datos ubicada en la misma carpeta
RutaActual = ActiveWorkbook.Path
NombreFichero = "BD.xlsx"
fic = RutaActual & "\" & NombreFichero
'intento abrir la BD. Si no puedo, lanzo una excepción
On Error GoTo GestionErrores
'abro la BD
Workbooks.Open fic
a = -1
b = -1
FilaInicial = 1
FilaFinal = 10
'busco el parametro en la col1 y extraigo a y b de las cols 2 y 3
For fil = FilaInicial To FilaFinal
If Cells(fil, 1).Value = Parametro Then
a = Cells(fil, 2).Value
b = Cells(fil, 3).Value
Exit For
End If
Next
'cierro la BD para seguir trabajando con el excel principal
ActiveWorkbook.Close
'si no se encontraron a y b. aplico la formula alternativa
If (a = -1 Or b = -1) Then
w = 32
b = 38
d = 1
Beta = (w / (d + w)) ^ 2
solucion = (((1 - Beta) / (Beta ^ 2)) * (0.72 + ((49 * Beta * viscosidad) / (Densidad * velocidad * d * 10 ^ (-6))))) * Densidad * ((velocidad ^ 2) / 2) / 10 ^ (5)
PerdidaPresion = solucion
Exit Function
End If
'si encuentro a y b aplico la formula principal
solucion = ((((a + (b * viscosidad) / (Densidad * velocidad * 10 ^ (-6)))) * Densidad * ((velocidad ^ 2) / 2))) / 10 ^ (5)
PerdidaPresion = solucion
Exit Function
GestionErrores:
MsgBox "No se pudo abrir " & NombreFichero, , "Error " & Err.Number
Exit Function
End Function
y este código asociado a un botón para probarlo:
Sub probarFormula()
Dim res As Double
res = PerdidaPresion(1, 1, 1, "Q-28/2")
Cells(1, 2).Value = res
End Sub
He supuesto que los parámetros a y b están en la BD que se llama BD.xlsx. Deberás adaptar estos detalles a tu caso particular. También hay un pequeño control de excepciones para capturar el error que pararía la macro en caso de que la BD cambiase de nombre o de carpeta. He supuesto que el excel de control y la BD se hallan en el mismo directorio.
Por último, cabe remarcar que la rutina de búsqueda se podría optimizar usando alguna función implementada en excel; pero de esta forma se garantiza la compatibilidad entre versiones, aunque se penaliza la velocidad en PCs lentos.
Ya me contarás.
Function PerdidaPresion(ByVal Densidad As Single, ByVal velocidad As Single, ByVal viscosidad As Single, ByVal Parametro As String) As Double
Dim RutaActual, NombreFichero, fic As String
Dim FilaInicial, FilaFinal, fil As Integer
Dim a, b, w, d As Single
Dim solucion, Beta As Double
'calculo el nombre de la base de datos ubicada en la misma carpeta
RutaActual = ActiveWorkbook.Path
NombreFichero = "BD.xlsx"
fic = RutaActual & "\" & NombreFichero
'intento abrir la BD. Si no puedo, lanzo una excepción
On Error GoTo GestionErrores
'abro la BD
Workbooks.Open fic
a = -1
b = -1
FilaInicial = 1
FilaFinal = 10
'busco el parametro en la col1 y extraigo a y b de las cols 2 y 3
For fil = FilaInicial To FilaFinal
If Cells(fil, 1).Value = Parametro Then
a = Cells(fil, 2).Value
b = Cells(fil, 3).Value
Exit For
End If
Next
'cierro la BD para seguir trabajando con el excel principal
ActiveWorkbook.Close
'si no se encontraron a y b. aplico la formula alternativa
If (a = -1 Or b = -1) Then
w = 32
b = 38
d = 1
Beta = (w / (d + w)) ^ 2
solucion = (((1 - Beta) / (Beta ^ 2)) * (0.72 + ((49 * Beta * viscosidad) / (Densidad * velocidad * d * 10 ^ (-6))))) * Densidad * ((velocidad ^ 2) / 2) / 10 ^ (5)
PerdidaPresion = solucion
Exit Function
End If
'si encuentro a y b aplico la formula principal
solucion = ((((a + (b * viscosidad) / (Densidad * velocidad * 10 ^ (-6)))) * Densidad * ((velocidad ^ 2) / 2))) / 10 ^ (5)
PerdidaPresion = solucion
Exit Function
GestionErrores:
MsgBox "No se pudo abrir " & NombreFichero, , "Error " & Err.Number
Exit Function
End Function
y este código asociado a un botón para probarlo:
Sub probarFormula()
Dim res As Double
res = PerdidaPresion(1, 1, 1, "Q-28/2")
Cells(1, 2).Value = res
End Sub
He supuesto que los parámetros a y b están en la BD que se llama BD.xlsx. Deberás adaptar estos detalles a tu caso particular. También hay un pequeño control de excepciones para capturar el error que pararía la macro en caso de que la BD cambiase de nombre o de carpeta. He supuesto que el excel de control y la BD se hallan en el mismo directorio.
Por último, cabe remarcar que la rutina de búsqueda se podría optimizar usando alguna función implementada en excel; pero de esta forma se garantiza la compatibilidad entre versiones, aunque se penaliza la velocidad en PCs lentos.
Ya me contarás.
El que me pasaste funcionaba bien pero al adaptarlo no se que pasa... El código es genial! Y parece que para el macro funciona perfecto el problema es que la fórmula no reconoce el dato de búsqueda y no encuentra nada que la fórmula deja de funcionar y creo que no toco nada en la función de búsqueda...
El problema esta en que no reconoce el código. Voy a adjuntar el código y un ejemplo de tabla y si tiene un momento para mirarlo... siento tanta molestia y se lo agradezco muchísimo. Function PerdidaPresion(ByVal Dichte As Single, ByVal Geschwindigkeit As Single, ByVal Viskositat As Single, ByVal Parametro As String) As Double
Dim RutaActual, NombreFichero, fic As String
Dim FilaInicial, FilaFinal, fil As Integer
Dim a, b, w, d As Single
Dim solucion, Beta As Double
'calculo el nombre de la base de datos ubicada en la misma carpeta
RutaActual = "C:\Dokumente und Einstellungen\glopez\Desktop\DATOS"
NombreFichero = "KATALOG2.xls"
fic = RutaActual & "\" & NombreFichero
'intento abrir la BD. Si no puedo, lanzo una excepción
On Error GoTo GestionErrores
'abro la BD
Workbooks.Open fic
a = -1
b = -1
FilaInicial = 1
FilaFinal = 256
'busco el parametro en la col1 y extraigo a y b de las cols 2 y 3
For fil = FilaInicial To FilaFinal
If Cells(fil, 1).Value = Parametro Then
a = Cells(fil, 5).Value
b = Cells(fil, 6).Value
Beta = Cells(fil, 7).Value
d = Cells(fil, 4).Value
Exit For
End If
Next
ActiveWorkbook.Close
'si no se encontraron a y b. aplico la fórmula alternativa
If (a = 0) And (b = 0) Then
MsgBox Beta
MsgBox d
solucion = (((1 - Beta) / (Beta ^ 2)) * (0.72 + ((49 * Beta * Viskositat) / (Dichte * Geschwindigkeit * d * 10 ^ (-6))))) * Dichte * ((Geschwindigkeit ^ 2) / 2) / 10 ^ (5)
PerdidaPresion = solucion
Exit Function
End If
MsgBox a
MsgBox b
'si encuentro a y b aplico la formula principal
solucion = ((((a + ((b * Viskositat) / (Dichte * Geschwindigkeit * 10 ^ (-6)))) * Dichte * ((Geschwindigkeit ^ 2) / 2))) / 10 ^ (5))
PerdidaPresion = solucion
Exit Function
GestionErrores:
MsgBox "No se pudo abrir " & NombreFichero, , "Error " & Err.Number
Exit Function
End Function
Sub probarFormula()
Dim res As Double
res = PerdidaPresion(800, 2, 0.01, "122/90")
Cells(1, 3).Value = res
End Sub
Ejemplo de tabla
name name W D a b Beta
20/20 20/20 20 20 3 4 0.25
25/25 25/25 25 25 5 4 0.25
32/25 32/25 32 25 7 4 0.3151739
32/28 32/28 32 28 9 4 0.28444444
36/28 36/28 36 28 11 4 0.31640625
38/25 38/25 38 25 0 0 0.3638196
40/23 40/23 40 23 0 0 0.40312421
40/25 40/25 40 25 0 2.85 0.37869822
40/28 40/28 40 28 0 2.85 0.34602076
40/32 40/32 40 32 0 2.85 0.30864198
42/36 42/36 42 36 3.9 2.85 0.28994083
45/18 45/18 45 18 3.9 2.85 0.51020408
45/32 45/32 45 32 3.9 2.85 0.34154158
45/36 45/36 45 36 3.9 2.85 0.30864198
El problema esta en que no reconoce el código. Voy a adjuntar el código y un ejemplo de tabla y si tiene un momento para mirarlo... siento tanta molestia y se lo agradezco muchísimo. Function PerdidaPresion(ByVal Dichte As Single, ByVal Geschwindigkeit As Single, ByVal Viskositat As Single, ByVal Parametro As String) As Double
Dim RutaActual, NombreFichero, fic As String
Dim FilaInicial, FilaFinal, fil As Integer
Dim a, b, w, d As Single
Dim solucion, Beta As Double
'calculo el nombre de la base de datos ubicada en la misma carpeta
RutaActual = "C:\Dokumente und Einstellungen\glopez\Desktop\DATOS"
NombreFichero = "KATALOG2.xls"
fic = RutaActual & "\" & NombreFichero
'intento abrir la BD. Si no puedo, lanzo una excepción
On Error GoTo GestionErrores
'abro la BD
Workbooks.Open fic
a = -1
b = -1
FilaInicial = 1
FilaFinal = 256
'busco el parametro en la col1 y extraigo a y b de las cols 2 y 3
For fil = FilaInicial To FilaFinal
If Cells(fil, 1).Value = Parametro Then
a = Cells(fil, 5).Value
b = Cells(fil, 6).Value
Beta = Cells(fil, 7).Value
d = Cells(fil, 4).Value
Exit For
End If
Next
ActiveWorkbook.Close
'si no se encontraron a y b. aplico la fórmula alternativa
If (a = 0) And (b = 0) Then
MsgBox Beta
MsgBox d
solucion = (((1 - Beta) / (Beta ^ 2)) * (0.72 + ((49 * Beta * Viskositat) / (Dichte * Geschwindigkeit * d * 10 ^ (-6))))) * Dichte * ((Geschwindigkeit ^ 2) / 2) / 10 ^ (5)
PerdidaPresion = solucion
Exit Function
End If
MsgBox a
MsgBox b
'si encuentro a y b aplico la formula principal
solucion = ((((a + ((b * Viskositat) / (Dichte * Geschwindigkeit * 10 ^ (-6)))) * Dichte * ((Geschwindigkeit ^ 2) / 2))) / 10 ^ (5))
PerdidaPresion = solucion
Exit Function
GestionErrores:
MsgBox "No se pudo abrir " & NombreFichero, , "Error " & Err.Number
Exit Function
End Function
Sub probarFormula()
Dim res As Double
res = PerdidaPresion(800, 2, 0.01, "122/90")
Cells(1, 3).Value = res
End Sub
Ejemplo de tabla
name name W D a b Beta
20/20 20/20 20 20 3 4 0.25
25/25 25/25 25 25 5 4 0.25
32/25 32/25 32 25 7 4 0.3151739
32/28 32/28 32 28 9 4 0.28444444
36/28 36/28 36 28 11 4 0.31640625
38/25 38/25 38 25 0 0 0.3638196
40/23 40/23 40 23 0 0 0.40312421
40/25 40/25 40 25 0 2.85 0.37869822
40/28 40/28 40 28 0 2.85 0.34602076
40/32 40/32 40 32 0 2.85 0.30864198
42/36 42/36 42 36 3.9 2.85 0.28994083
45/18 45/18 45 18 3.9 2.85 0.51020408
45/32 45/32 45 32 3.9 2.85 0.34154158
45/36 45/36 45 36 3.9 2.85 0.30864198
1. Desactiva la gestión de errores, temporalmente. Así veremos si Excel lanza algún mensaje
2. Añade a la BD un dato falso en alguna línea, por ejemplo, "x"
3. Prueba la fórmula con el parámetro "x"
4. Mira si devuelve un valor. Si es así, entonces las celdas de las columna 1 o no tienen formato de texto o bien el contenido de estas celdas tienen un espacio en blanco o algo por el estilo. No es lo mismo "45/36" que "45/36 ". Si la celda tiene formato "General" puede que tampoco funcione.
2. Añade a la BD un dato falso en alguna línea, por ejemplo, "x"
3. Prueba la fórmula con el parámetro "x"
4. Mira si devuelve un valor. Si es así, entonces las celdas de las columna 1 o no tienen formato de texto o bien el contenido de estas celdas tienen un espacio en blanco o algo por el estilo. No es lo mismo "45/36" que "45/36 ". Si la celda tiene formato "General" puede que tampoco funcione.
Ya esta claro. El problema esta en que la funci'on parece que no es capaz de abrir el excel. El macro si con el mismo código... pero la función no lo hace. ¿Conoce algún método para lograr que la función lo habrá? Estoy probando con ADODB pero es complicado.
Siento las molestia y agradezco muchísimo el esfuerzo.
Siento las molestia y agradezco muchísimo el esfuerzo.
No debería haber problemas para abrir el fichero Excel si la ruta y el nombre de fichero son correctos. Crea un Excel de prueba y lo guardas en la carpeta del Excel que lo llama. Vigila el nombre de ruta. Si funciona habría que mirar si hay restricciones a la hora de acceder a la BD.
Perdona por no haber escrito antes estaba trabajando en la solución. Al final lo logre pero para ello programe una clase que extraía la información de un archivo. Si te interesa el código lo cuelgo...
Gracias por tu ayuda y tiempo dedicado
Gracias por tu ayuda y tiempo dedicado