XL 2019 Remplir une cellule d'un fichier excel fermé

Option Explicit

Sub TheUpdator()
Dim WBSource As Workbook, WBCible As Workbook
Dim WSSource As Worksheet, WSCible As Worksheet
Dim PlageSource As Range
Dim ThePath As String, FileName As String
Dim LigneSource As Integer, LigneSourceMax As Integer
Dim FileCount As Integer

Set WBSource = ThisWorkbook
Set WSSource = WBSource.Worksheets("Feuil1")
Set PlageSource = WSSource.Range("B4:B" & WSSource.Range("A100").End(xlUp).Row)

LigneSource = 4
LigneSourceMax = PlageSource.Rows.Count

ThePath = WBSource.Path & "\"
FileName = Dir(ThePath & "*.xlsx")
    If FileName <> ThisWorkbook.Name Then
        Do While Len(FileName) > 0 And FileCount < LigneSourceMax
            Set WBCible = Workbooks.Open(ThePath & FileName)
            Set WSCible = WBCible.Worksheets(1) ' On part du principe que c'est la feuille 1 ?
            
            With WSCible
                .Unprotect
                .Range("E13").Value = WSSource.Range("B" & LigneSource).Value
                .Range("E14").Value = WSSource.Range("C" & LigneSource).Value
                .Protect
            End With
            
            With WBCible
            .Save
            .Close
            End With
            
            LigneSource = LigneSource + 1
            FileCount = FileCount + 1
            FileName = Dir()
        Loop
    End If
End Sub

Sub Traiter()
Dim chemin$, fichier$(1 To 2), ad$(1 To 3), c As Range, i%, j% 'tableaux à dimensionner
chemin = ThisWorkbook.Path & "\"
fichier(1) = "BAC-PRO-MELEC-Grilles-Eval-CCF-µ-juin-2020.xlsx" 'mois à adapter
fichier(2) = "BEP-MELEC-Grilles-Eval-CCF-µ-juin-2020.xlsx" 'mois à adapter
ad(1) = "E13" 'adresse de destination à adapter
ad(2) = "E15" 'adresse de destination à adapter
ad(3) = "E17" 'adresse de destination à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
On Error Resume Next 'si le fichier n'existe pas
For Each c In [A1].CurrentRegion.Columns(1).Cells
    For i = 1 To UBound(fichier)
        With Workbooks.Open(chemin & Replace(fichier(i), "µ", c & "-" & c(1, 2)))
            For j = 1 To UBound(ad)
                .Sheets(1).Range(ad(j)) = c(1, j)
            Next j
            .Close True 'enregistrement et fermeture
        End With
Next i, c
End Sub

Const feuille$ = "Feuil1" 'à adapter, mémorise le nom des feuilles de destination pour ADO

Sub Traiter_ADO()
Dim chemin$, fichier$(1 To 2), ad$(1 To 3), c As Range, i%, fich$ 'tableaux à dimensionner
chemin = ThisWorkbook.Path & "\"
fichier(1) = "BAC-PRO-MELEC-Grilles-Eval-CCF-µ-juin-2020.xlsx" 'mois à adapter
fichier(2) = "BEP-MELEC-Grilles-Eval-CCF-µ-juin-2020.xlsx" 'mois à adapter
ad(1) = "E13" 'adresse à adapter
ad(2) = "E15" 'adresse à adapter
ad(3) = "E17" 'adresse à adapter
On Error Resume Next 'si le fichier n'existe pas
For Each c In [A1].CurrentRegion.Columns(1).Cells
    For i = 1 To 2
        fich = chemin & Replace(fichier(i), "µ", c & "-" & c(1, 2))
        Export fich, ad, c
Next i, c
End Sub

Sub Export(fich$, ad$(), c As Range)
Dim Cn As ADODB.Connection, Cd As ADODB.Command, j%, Rst As ADODB.Recordset
Set Cn = New ADODB.Connection
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & fich & ";" & "Extended Properties=""Excel 12.0;HDR=NO;"""
Set Cd = New ADODB.Command
Cd.ActiveConnection = Cn
For j = 1 To 3
    Cd.CommandText = "SELECT * FROM [" & feuille & "$" & ad(j) & ":" & ad(j) & "]"
    Set Rst = New ADODB.Recordset
    Rst.Open Cd, , adOpenKeyset, adLockOptimistic
    Rst(0) = c(1, j)
    Rst.Update
Next
Cn.Close
Set Cn = Nothing
Set Cd = Nothing
Set Rst = Nothing
End Sub

Const feuille$ = "Feuil1" 'à adapter, mémorise le nom des feuilles de destination pour ADO

Sub Traiter_ADO()
Const fichier  As String = "[DIPLÔME]-MELEC-Grilles-Eval-CCF-[NOM]-[PNOM]-[MOIS]-[ANNEE].xlsx" 'mois à adapter
Dim chemin$, ANNEE$, MOIS$, ad$(1 To 3), c As Long, i%, fich$ 'tableaux à dimensionner
chemin = ThisWorkbook.Path & "\"
ad(1) = "E13" 'adresse à adapter
ad(2) = "E15" 'adresse à adapter
ad(3) = "E17" 'adresse à adapter
ANNEE = 2020: MOIS = "juin"
'On Error Resume Next 'si le fichier n'existe pas
Dim Cn As New ADODB.Connection: Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=NO;"""
With ThisWorkbook.Sheets("Feuil1")
    For i = 1 To .Range("A1").CurrentRegion.Rows.Count - 1
        fich = chemin & Replace(Replace(Replace(Replace(Replace(fichier, "[NOM]", .Range("A1").Offset(i, 1)), "[PNOM]", .Range("A1").Offset(i, 2)), "[MOIS]", MOIS), "[ANNEE]", ANNEE), "[DIPLÔME]", .Range("A1").Offset(i))
        
            
            Export fich, ad, .Range("A1").Offset(i), Cn
    Next
End With
Cn.Close
Set Cn = Nothing
End Sub

Sub Export(fich$, ad$(), c As Range, Cn As ADODB.Connection)

Dim Cd As ADODB.Command, j%, Rst As ADODB.Recordset, Ch As String

Set Cd = New ADODB.Command
Cd.ActiveConnection = Cn
For j = 1 To 3
 Ch = IIf(IsNumeric(c(1, j)), "", "'")
    Cd.CommandText = "update [" & feuille & "$" & ad(j) & ":" & ad(j) & "] in '" & fich$ & "' 'Excel 12.0;HDR=NO' set [F1]=" & Ch & c(1, j).Offset(, 1) & Ch & ";"
    Cd.Execute
    
Next

Set Cd = Nothing
'Set Rst = Nothing''
End Sub