Jump to content
Sign in to follow this  
marcosab

ANSWERED Macro para Consulta, Actualización desde ACCESS

Recommended Posts

Buenos días 

Primero que todo debo dar gracias por toda la ayuda de los miembros del foro.

Estoy iniciando con un sistema para registrar información de un proceso con macros en EXCEL que utiliza información de ACCESS, el sistema se debe utilizar por varias personas.

 

Tengo las siguientes dudas que acudo a ustedes para resolverlas.

Usuario admin

Contraseña 123

1 Logre que detecte usuario y contraseña de una hoja de Excel. requiero que esa información la tome de la base de datos "01.Adeudos" tabla "usuarios". Además que que dependiendo las horjas activas sean visualizadas o ocultas. solo el administrador debe tener acceso a todas las hojas.

2 En la hoja "Registro" debe consultar a la base de datos "01.Adeudos" tabla "pen" y completar datos. despues el usuario debe completar datos y permitir actualizar los datos en la base de datos "01.Adeudos" tabla "usuarios".

 

https://mega.nz/file/MB5HyTib#5TMCNyAY50kXBSkCSe29piGkEYL9hoxhVtUzUzfu3Xk

 

 

Saludos,

Share this post


Link to post
Share on other sites

Hola

Claro que se puede hacer ambas cosas, no recibes respuesta porque no has hecho preguntas puntuales y no necesariamente en los foros la gente tiene tiempo de hacer todo un desarrollo (algunos lo tienen a veces). Como para que vayas intentando, la clave está en las sentencias SQL que debes usar. Mira el ejemplo 8 de mi blog:

https://abrahamexcel.blogspot.com/

Saludos

Share this post


Link to post
Share on other sites

Buenos dias

 

Muchas gracias por su respuesta, disculpa si enfoque mal la pregunta fue que tenia la duda de que se pudiera hacer eso desde excel, gracias por aclarar y tener certeza de que si es posible.

Es un proyecto grande resolviendo esas consultas me parece puedo completar hacer de mi parte el resto del proyecto.

Gracias por sus aportes.

Saludos  

Share this post


Link to post
Share on other sites

Muchas gracias por el aporte

 

He estado trabajando en el registro

tengo este codigo para agregar datos pero no logro que me los agregue favor ayuda para detectar el problema

 

 

Function ingesarDatos_01() As Boolean
    Dim sSQL As String
    Dim sSQLIngreso_01 As String
    Dim nResultado As Long
    Dim nFila As Double
    Dim rCelda As Range
    Dim sTexto As String
    
    ingesarDatos_01 = False
    '--------------------------------------------------------------------------------
    'obtenemos la ultima fila con datos
    '--------------------------------------------------------------------------------
    
    '--------------------------------------------------------------------------------
    'Creamos el String de Ingreso de datos
    '--------------------------------------------------------------------------------
    sSQL = "INSERT INTO 02_morosos (Cedula, Carpeta, Funcionario_1, Fecha_1, Numero_Patrono, Nombre_Patrono) "
    sSQL = sSQL & "VALUES ('" & Worksheets("Registro_01").Range("C9").Value & "', "
    sSQL = sSQL & Worksheets("Registro_01").Range("J2").Value & ", "
    sSQL = sSQL & Worksheets("Registro_01").Range("C6").Value & ", "
    sSQL = sSQL & "#" & Format(Worksheets("Registro_01").Range("F6").Value) & "#, "
    sSQL = sSQL & Worksheets("Registro_01").Range("C13").Value & ", "
    sSQL = sSQL & Worksheets("Registro_01").Range("E13").Value & ", "

    '--------------------------------------------------------------------------------
    'realizamos el ingreso de los datos para cada linea
    'si todo salio OK, nResultado sera 0
    '--------------------------------------------------------------------------------

        If nResultado <> 0 Then
            MsgBox "Problemas al ingresar el registro", vbCritical, "SACI"
            Exit Function
        End If

    MsgBox "Datos actualizados con Exito!!!", vbInformation, "SACI"
    ingesarDatos_01 = True
End Function

 

Share this post


Link to post
Share on other sites

Te dejo la macro Consultar, cuando pueda iré por la macro Actualizar:

Sub Consultar()

Dim Cnn As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim Sql As String, Datos As Variant
Dim NumId As String

Application.ScreenUpdating = False
NumId = [C9]
Set Cnn = New ADODB.Connection
With Cnn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\Datos\01.Adeudos.accdb"
    .Open
End With
Set Rs = New ADODB.Recordset
Sql = "SELECT Riesgo, [Monto Caso], Nombre FROM pen WHERE [Num Id] = '" & NumId & "'"
Rs.Open Sql, Cnn, 3, 3, adCmdText
Application.EnableEvents = False
[E9] = ""
[G9] = ""
[C11] = ""
If Not Rs.EOF = True Then
   Datos = Rs.GetRows 'Matriz columna/fila
   [E9] = Datos(0, 0)
   [G9] = Datos(1, 0)
   [C11] = Datos(2, 0)
Else
   MsgBox "*** Cédula: " & [C9] & " no encontrada ***", vbInformation
End If
Cnn.Close
Application.EnableEvents = True

End Sub

 

Share this post


Link to post
Share on other sites
Hace 2 horas, Antoni dijo:

Te dejo la macro Consultar, cuando pueda iré por la macro Actualizar:


Sub Consultar()

Dim Cnn As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim Sql As String, Datos As Variant
Dim NumId As String

Application.ScreenUpdating = False
NumId = [C9]
Set Cnn = New ADODB.Connection
With Cnn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\Datos\01.Adeudos.accdb"
    .Open
End With
Set Rs = New ADODB.Recordset
Sql = "SELECT Riesgo, [Monto Caso], Nombre FROM pen WHERE [Num Id] = '" & NumId & "'"
Rs.Open Sql, Cnn, 3, 3, adCmdText
Application.EnableEvents = False
[E9] = ""
[G9] = ""
[C11] = ""
If Not Rs.EOF = True Then
   Datos = Rs.GetRows 'Matriz columna/fila
   [E9] = Datos(0, 0)
   [G9] = Datos(1, 0)
   [C11] = Datos(2, 0)
Else
   MsgBox "*** Cédula: " & [C9] & " no encontrada ***", vbInformation
End If
Cnn.Close
Application.EnableEvents = True

End Sub

 

Pues aquí está la macro Actualizar:

Sub Actualizar()

Dim Cnn As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim Sql As String
Dim NumId As String

Application.ScreenUpdating = False
If Not [G11] = "SI" And Not [G11] = "NO" Then
   MsgBox "*** Moroso: " & [G11] & " valores SI/NO ***", vbCritical
   Exit Sub
End If
If Trim([C13]) = "" Then
   MsgBox "*** Número Patronal en blanco ***", vbCritical
   Exit Sub
End If
If Trim([E13]) = "" Then
   MsgBox "*** Nombre Patronal en blanco ***", vbCritical
   Exit Sub
End If

NumId = [C9]
Set Cnn = New ADODB.Connection
With Cnn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\Datos\01.Adeudos.accdb"
    .Open
End With
Set Rs = New ADODB.Recordset
Sql = "SELECT Moroso, Nun_Patrono, Nom_Patrono FROM pen WHERE [Num Id] = '" & NumId & "'"
Rs.Open Sql, Cnn, 3, 3, adCmdText
If Not Rs.EOF = True Then
   Rs.Fields("Moroso").Value = [G11]
   Rs.Fields("Nun_Patrono").Value = [C13]
   Rs.Fields("Nom_Patrono").Value = [E13]
   Rs.Update
   Application.EnableEvents = False
   [G11] = ""
   [C13] = ""
   [E13] = ""
   Application.EnableEvents = True
Else
   MsgBox "*** Cédula: " & [C9] & " no encontrada ***", vbCritical
End If
Cnn.Close

End Sub

 

Edited by Antoni

Share this post


Link to post
Share on other sites

Muchas gracias 

Estaba revisando la información y requiero de la ayuda en lo siguiente:


1 Requiero que esa información la tome de la base de datos "01.Adeudos" tabla "usuarios". Además que que dependiendo las hojas activas sean visualizadas o ocultas. solo el administrador debe tener acceso a todas las hojas. Esto funciona solo si hay solo si el usuario activa una hoja pero si se requiere que estén activas mas de una hoja no funciona. ejemplo el user marco pass 123 debería tener activas las hojas "Registro, Registro1, Registro2". como esta ahorita solo visualiza la hoja "Registro"

Ademas un favor extra que dependiendo el usuario que inicie sección detecte el Nombre de la columna "Nombre" en ("01.Adeudos" tabla "usuarios") y lo pegue en la hoja "Principal" celda C7.

 

De nuevo muchas gracias por toda la ayuda en el proyecto.

Saludos

Share this post


Link to post
Share on other sites
Sign in to follow this  



  • Posts

    • ¡Hola a todos! Revisa el adjunto.  ¡Bendiciones! Libro1 (7).xlsx
    • Amigos, estoy muy agradecido con todos por tratar de ayudarme a resolver el dilema de ocultar la contraseña en el ImputBox. Desafortunadamente ninguna de las soluciones me llevo al exito. Pero, la buena noticia es que trasteando un poco en la red, encontre la solucion, y se las dejo por si alguien la necesita.   Option Explicit'---------------------------------- 'API CONSTANTS FOR PRIVATE INPUTBOX '---------------------------------- #If VBA7 Then Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, _ ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias _ "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" _ (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long #Else Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias _ "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _ (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long #End If 'Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 #If VBA7 Then Private hHook As LongPtr #Else Private hHook As Long #End If '---------------------------------- 'PRIVATE PASSWORDS FOR INPUTBOX '---------------------------------- '//////////////////////////////////////////////////////////////////// 'Password masked inputbox 'Allows you to hide characters entered in a VBA Inputbox. ' 'Code written by Daniel Klann 'March 2003 '64-bit modifications developed by Alexey Tseluiko 'and Ryan Wells (wellsr.com) 'February 2019 '//////////////////////////////////////////////////////////////////// #If VBA7 Then Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPtr #Else Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long #End If Dim RetVal Dim strClassName As String, lngBuffer As Long If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then 'This changes the edit control so that it display the password character *. 'You can change the Asc("*") as you please. SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, asc("*"), &H0 End If End If 'This line will ensure that any other hooks that may be in place are 'called correctly. CallNextHookEx hHook, lngCode, wParam, lParam End Function Function InputBoxDK(Prompt, Title) As String #If VBA7 Then Dim lngModHwnd As LongPtr #Else Dim lngModHwnd As Long #End If Dim lngThreadID As Long lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) InputBoxDK = InputBox(Prompt, Title) UnhookWindowsHookEx hHook End Function Adicionalmente dejo el link de la pagina de donde lo extraje, y el archivo con el codigo para que lo vean. Solucion Un abrazo, y de nuevo muchas gracias a todos. Tema solucionado!     Inputbox funcionando.xlsm
    • Hola Tu Office es de 64 bits y en el archivo de ejemplo enviado hay varias funciones de la API de Windows que hay que modificar en las declaraciones. Modifica toda la parte que está entre la línea #If VBA7 Then y la línea #Else reemplazando por las siguientes: Private Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr Private Declare PtrSafe Function TerminateProcess Lib "kernel32" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long   Yo prefiero usar Public, pero lo dejo en Private como te lo han mostrado. Saludos.
    • Estiamados foristas, acudo a Uds para encontrar ayuda al siguiente tema. Tengo una matriz en power bi en la que coloque el ID de una tabla producto y 3 medidas: 1er fecha 2da fecha Dias entre fechas Lo que necesito encontrar es que me traiga una nueva medida en que los dias entre fechas sea >= a 365 dias Trate de hacerlo con un CALCULATE -  ALL - FILTER pero o no me toma argumentos booleanos o no me toma la medida de dias entre fechas ya que no es una columna no esta en la tabla origen (es una medida calculada) Les paso en excel el ejemplo Dede ya muchas gracias data.xlsx
    • Hola Gerson Muchas gracias por tus archivos. No tengo Office 365 por lo que el primer archivo no lo puede utilizar. El segundo funciona perfectamente pero si intento crear más columnas me aparece error. El tercero no lo entiendo porque no veo ninguna fórmula en la tabla resumen. ¿Me puedes explicar el significado de lo que he marcado en verde? =SI(FILAS($A$1:$A1)>$B$12;"";INDICE(data!$A$10:$F$29;AGREGAR(15;6;FILA(data!$A$10:$A$29)-9/((data!$A$10:$A$29>=$C$7)*(data!$A$10:$A$29<=$C$8));FILAS($A$1:$A1));COLUMNAS($A$1:A$1))) Muchas gracias de nuevo Gerson. Saludos 
  • Recently Browsing

    No registered users viewing this page.

×
×
  • Create New...

Important Information

Privacy Policy