Mettre à jour un fichier Excel fermé

Bonjour tout le monde,

Je doit mettre à jour un classeur Excel fermé par des données provenant d'une feuille Excel active.

Avec le code ci-dessous j'arrive à mettre à jour l'enregistrement souhaitée en fonction d'un critère (ID), cependant lorsque je mets une valeur bidon pour le critère qui n 'existe pas dans la table cible, le code s’exécute sans message d'erreur et sans mise à jour, ce qui est normal, mais je ne suis pas informé si la màj est effectuée ou non.

mon objectif est d'ajouter au code une instruction dans ce cas qui va me permettre de savoir si le critère de la mise à jour est inexistant dans la table cible, chose que je n'ai pas réussi à le faire

Merci par avance pour votre aide

Code :

Sub miseAJour_Enregistrement()

Dim Cn As ADODB.Connection

Dim Fichier As String, Feuille As String, strSQL As String

Dim CP, SV As Long

Dim Codeprojet As String

Fichier = "C:\Doc\vba\Suivi_OS_OKIT.xlsm"

Feuille = "SuiviOS"

CP = ThisWorkbook.ActiveSheet.Range("I27")

SV = ThisWorkbook.ActiveSheet.Range("N27")

Codeprojet = ThisWorkbook.ActiveSheet.Range("I7")

Set Cn = New ADODB.Connection

With Cn

.Provider = "Microsoft.Jet.OLEDB.4.0"

.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _

& Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""

.Open

End With

strSQL = "UPDATE [" & Feuille & "$] SET " & _

"[OS] = '" & CP & "'" & "WHERE [ID] = " & Codeprojet & ""

Cn.Execute strSQL

Cn.Close

Set Cn = Nothing

End Sub

Bonjour,

Il suffit de chercher l'ID avant avec un simple SELECT du genre :

Option Explicit

Public Cnx As Object, Rst As Object

Sub miseAJour_Enregistrement()
Dim Codeprojet As Long
Dim strSQL As String, Feuille As String

    Codeprojet = ThisWorkbook.ActiveSheet.Range("I7")
    CP = ThisWorkbook.ActiveSheet.Range("I27")

    If Test_ID(Codeprojet) Then
        Connect_xls "C:\Doc\vba\Suivi_OS_OKIT.xlsm"
        strSQL = "UPDATE [SuiviOS$] SET OS = '" & CP & "'" & "WHERE `ID` = " & Codeprojet
        Cnx.Execute strSQL
        Close_xls
    Else
        MsgBox "ID =" & Codeprojet & " n'existe pas"
    End If
End Sub

Function Test_ID(ID As Long) As Boolean
Dim Req As String, T As Variant

    Connect_xls "C:\Doc\vba\Suivi_OS_OKIT.xlsm"
    Req = "SELECT * FROM [SuiviOS$] WHERE `ID`=" & ID
    T = Select_Xls_Accdb(Req)
    Close_xls 1
    Test_ID = Not (T(0, 0) = "")
End Function

Sub Connect_xls(Ndf As String)
    Set Cnx = CreateObject("ADODB.Connection")
    Cnx.Provider = "MSDASQL"
    Cnx.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
             "DBQ=" & Ndf & "; ReadOnly=False;"
    Set Rst = CreateObject("ADODB.Recordset")
End Sub

Sub Close_xls(Optional x As Byte)
    If x > 0 Then Rst.Close
    Cnx.Close
    Set Cnx = Nothing
    Set Rst = Nothing
End Sub

Merci pierrep56 pour ton retour

Il semble qu'il y a un souci entre la variable codeprojet et la variable ID de la fonction Test_ID.

dés que j'execute la procédure miseAJour_Enregistrement(), un message d'erreur s'affiche :"type d'argument byref incompatible"

PI: le champ ID de la table cible contient des codes composés de 6 chiffres

On peut essayer de remplacer

Dim Codeprojet As Long

par

Dim Codeprojet As String

et

Function Test_ID(ID As Long)

par

Function Test_ID(ID As String)

A tester ...

En effet, après changement du type de variable, plus de message d'erreur et la valeur du code projet est renvoyé.

mais maintenant ça bloque au niveau de la ligne : T = Select_Xls_Accdb(Req)

msg error "Cub ou Function non définie"

Ah, j'avais oublié de mettre cette partie de code :

Function Select_Xls_Accdb(Req As String) As Variant
Dim T() As Variant

    ReDim T(0, 0)
    Rst.Open Req, Cnx, 3
    If Rst.RecordCount > 0 Then
        ReDim T(Rst.Fields.Count - 1, Rst.RecordCount - 1)
        Rst.MoveFirst
        T = Rst.GetRows
    End If
    Select_Xls_Accdb = Transpose(T)
End Function

Function Transpose(Ttk As Variant) As Variant
Dim T As Variant, lg As Long, cl As Long, i As Long, j As Long

    lg = UBound(Ttk, 1)
    cl = UBound(Ttk, 2)
    ReDim T(LBound(Ttk, 2) To cl, LBound(Ttk, 1) To lg)
    For i = LBound(Ttk, 2) To cl
        For j = LBound(Ttk, 1) To lg
            T(i, j) = Ttk(j, i)
        Next j
    Next i
    Transpose = T
End Function

Maintenant ça bloque au niveau de la fonction Function Select_Xls_Accdb(Req As String) As Variant sur la ligne

Rst.Open Req, Cnx, 3 avec le message d'erreur :

erreur d'execution -2147217913(80040e07)

[microsoft] [pilote ODBC Excel] type de donnée incompatible dans l'expression du critère.

Déolé pierrep56 c'est la première fois que j'utilise les connexion ADO et SQL

Voici une démo dans laquelle le code proposé fonctionne.

La source est en Feuil1, la cible en Feuil2 sur le même fichier.

/!\ Pour adapter le code, il est nécessaire de modifier les noms des fichiers, les noms des onglets et les références des cellules.

Pierre

Merci beaucoup Pierre, cela fonctionne parfaitement