Bonjour à tous,
J'utilise un fichier partagé avec un système d'enregistrement dans une base.xlsx
Malheureusement si plusieurs personnes enregistrent en même temps, j'ai une jolie erreur
J'ai vu que Excel ne gérait pas les verrouillages optimistes ou pessimistes. Exist-il quand même une parade, une fonction similaire ?
Merci
A+
J'utilise un fichier partagé avec un système d'enregistrement dans une base.xlsx
Malheureusement si plusieurs personnes enregistrent en même temps, j'ai une jolie erreur
J'ai vu que Excel ne gérait pas les verrouillages optimistes ou pessimistes. Exist-il quand même une parade, une fonction similaire ?
Merci
A+
Code:
Sub Fermer_et_sauvegarder()
Dim Cn As ADODB.Connection
Dim Cd As ADODB.Command
Dim Rst As ADODB.Recordset
Dim Fichier As String, NomFeuille As String
Dim VSearch As String, i As Integer, L As Integer
Dim DernLigne As Long
' Chemin d'accès de la base
Fichier = "D:\Base\Base_FI.xlsx"
'Nom de la feuille dans le classeur fermé
NomFeuille = "BaseFI"
' Créer la connexion
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=NO;"""
.Open
End With
Set Cd = New ADODB.Command
Cd.ActiveConnection = Cn
' Ouvrir 1000 lignes d'enegistrement
Cd.CommandText = "SELECT * FROM [BaseFI$A1:AA65000]"
Set Rst = New ADODB.Recordset
Rst.Open Cd, , adOpenKeyset, adLockOptimistic
' Boucler sur plusieurs lignes
DernLigne = Sheets("Fiche").Range("A" & Rows.Count).End(xlUp).Row
For L = 20 To DernLigne
' Chercher la valeur dans la BdD
Rst.Find "F1 = '" & Cells(L, 1) & "'", , adSearchForward, 1
' Si on se retrouve à la fin des enregistrement
' On en créé un nouveau
If Rst.EOF = True Then Rst.AddNew
' On rempli la ligne d'enregistrement avec les valeurs
For i = 0 To 26 ' Mettre ici le nombre de champs -1
Rst(i).Value = Sheets("Fiche").Cells(L, 1 + i)
Next i
Next L
' Metre à jour la ligne d'enregistrement
Rst.Update
' Fermer la connexion
Cn.Close
' Effacer les variables objet
Set Cn = Nothing
Set Cd = Nothing
Set Rst = Nothing
End Sub