Option Explicit
Dim oCon As ADODB.Connection
Const sFeuille As String = "PARAM$" 'Changer avec le nom de ma feuille que tu veux modifier + Attention à ne pas oublier le signe $ après le nom de l'onglet
Sub MAJ_DataDansFichiersFermés()
Dim x As Integer, iCompteur As Integer
'Dim sRep As String
Dim oFso As Object
Dim oFile As Object
Dim oDirectory As Object
Dim oRs As ADODB.Recordset
'# On demande la valeur à mettre à jour dans les fichiers
' Do
x = Application.InputBox("Veuillez saisir la donnée à mettre à jour", "MAJ donnée", , , , , , 1)
' Select Case x
' Case 1 To 12
' Exit Do
' Case 0
' Exit Sub
' Case Else
' MsgBox "Vous devez saisir un chiffre compris entre 1 et 12 !", vbOKOnly + vbExclamation, "Erreur de saisie"
' End Select
' Loop
'# Désactivation de certains paramètres pour accélerer le traitement
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'# Création des objets de scripting
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oDirectory = oFso.getfolder(Range("sPath"))
'# On active la gestion d'erreur
On Error GoTo GestionErreur
'# On vérifie qu'il y a bien des fichiers dans le répertoire
If Not (oDirectory.Files.Count > 0) Then
MsgBox "Le répertoire sélectionné ne contient aucun fichier !", vbCritical + vbOKOnly, "Erreur répertoire"
Set oFso = Nothing
Set oDirectory = Nothing
Exit Sub
End If
iCompteur = 0
'# On parcours tous les fichiers du répertoire
For Each oFile In oDirectory.Files
'# Si le fichier est un fichier excel 2007-12
If Right$(oFile.Name, 5) = ".xlsx" Then
'# Ouverture de la connection
Set oCon = New ADODB.Connection
'Chaîne de connexion pour Excel antérieur à 2007
'oCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & oFile.Path & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;"";"
oCon.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & oFile.Path & ";" & _
"Extended Properties=""Excel 12.0;HDR=No;"";"
'# On vérifie que l'onglet PARAM existe bien dans le fichier, sinon on passe à un autre fichier
If VerifierExistenceFeuille(sFeuille) Then
'# La feuille existe on peut donc effectuer la mise à jour
Set oRs = New ADODB.Recordset
With oRs
'.Open "SELECT * from [vMois]", oCon, adOpenKeyset, adLockOptimistic
'## Changer PARAM par le nom de feuille qui conviendra
.Open "SELECT * from [PARAM$B5:B5]", oCon, adOpenKeyset, adLockOptimistic
oRs(0).Value = x
.Update
.Close
End With
Application.StatusBar = "Fichier " & oFile.Name & " mis à jour"
iCompteur = iCompteur + 1
oCon.Close
End If
End If
Next
NormalEnd:
On Error Resume Next
'# On ferme les objets créés
Set oFso = Nothing
Set oDirectory = Nothing
Set oRs = Nothing
Set oCon = Nothing
'# Rétablissement des paramètres Excel
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = False
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "La mise à jour de " & iCompteur & " fichiers a été effectuée avec succès !", vbInformation + vbOKOnly, "Fin de traitement"
Exit Sub
GestionErreur:
MsgBox "Une erreur a eu lieu pendant le traitement. La procédure est interrompue.", vbCritical + vbOKOnly, "Erreur de traitement"
GoTo NormalEnd
End Sub
'===============================================================================
'= Fonction vérifiant l'existence d'une feuille dans un classeur fermé =
'= Nécessite d'activer la référence Microsoft ADO Ext. 2.8 for DDL and Security =
'===============================================================================
Function VerifierExistenceFeuille(sNomFeuille As String) As Boolean
Dim oCat As ADOX.Catalog
Dim Feuille As ADOX.Table
Set oCat = New ADOX.Catalog
Set oCat.ActiveConnection = oCon
On Error Resume Next
'Vérifie si la feuille "Feuil1" existe dans le classeur fermé
Set Feuille = oCat.Tables(sNomFeuille)
On Error GoTo 0
If Feuille Is Nothing Then
'La feuille n'existe pas
VerifierExistenceFeuille = False
Else
'La feuille existe
VerifierExistenceFeuille = True
End If
Set Feuille = Nothing
Set oCat = Nothing
End Function
'==========================================
'= Procédure de sélection d'un répertoire =
'= Utilise le scripting object =
'= A LIER à un bouton dans la feuille qui contient le range sPath
'==========================================
Sub SelectFolder()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
Range("sPath") = vrtSelectedItem
Next vrtSelectedItem
End If
End With
Set fd = Nothing
End Sub
.
