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

[Benes]

Bonjour a tous

J'ai bien avancé sur mon petit projet de mon petit niveau mais là...
j'ai besoin de remplir le nom , prénom et numéro de candidat d'une cinquantaine d’élève dans le nom d'un fichier excel fraîchement créé automatiquement.
Pour cette parti c'est fait, ouf j'ai réussi. Par contre dans ma boucle je dois aussi rajouter un petit bout de code pour aller mettre dans des cellule approprier de chaque fichier excel créé, le nom, prénom et num candidat. Je me suis dis que si je devais ouvrir le fichier a chaque fois pour y copier lces données, je serai faire mais le PC va mouliner pendant des heures et du coup ultra bof. Je me suis donc penché sur "comment remplir un fichier excel sans l'ouvrir" et j'ai trouvé des choses, mais dur dur.
J'ai tenter des ADODB.Connection j'ai dans les ref coché des MicrosoftActiveX... j'ai essayer des méthodes plus simple ou plus compliquer sur différent site (qui souvent date d'ailleurs) bref je crois tout simplement que ce n'est pas de mon niveau.
Je joins 2 malheureux fichiers, 1 la source et l'autre la destination. Si un connaisseur pouvait me donner un coup de main, cela m'aiderai grandement. L’idée serai de cliquer sur le bouton du fichier "source" et que ça remplisse les 3 cellules du fichier "destination". Pour la suite, je devrai réussir a adapter le bout de code a ma boucle.

Merci a vous

 

[_Thierry]

Re Bonjour @Benes, le Forum

J'ai écrit ce code, quand je "target" sur des Book1.xlsx, Book2.xlsx, Book3.xlsx, etc..
Tout fonctionne parfaitement :

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

Quand j'essaie sur ton fichier source "BAC-PRO-MELEC-Grilles-Eval-CCF-NOM_Prénom-juin-2020.xlsx" c'est comme si on "pissait dans un violon" (pas d'erreur mais NADA pas de nom ni prénom sauvegardés !)
J'ai bien vu que la feuille était protégée, ça je le gère, mais je ne vois pas pourquoi il ne veut pas sauver les Noms et Prénoms en E13 et E14 de la feuille "Paramètres"... Il y a des Gremlins dans ces spreadsheets !!!

Je dois faire autre chose, peut-être tu sauras pourquoi ?
Bon courage
@+Thierry

 

[job75]

Hello _Thierry,

Impossible d'ouvrir le fichier du post #6.

Je suppose donc que les noms sont en colonne A du fichier source.xlsm, les prénoms en colonne B et les numéros en colonne C.

Je suppose aussi que tous les fichiers sont dans le même dossier (celui du fichier source.xlsm).

Placez cette macro dans le fichier source.xlsm et exécutez-la :

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

Avec 100 fichiers de destination la macro s'exécute chez moi en 28 secondes (dont 10 secondes dues à l'enregistrement des fichiers traités).

C'est encore acceptable mais il est certain qu'avec la méthode ADO ce sera bien plus rapide.

 

[_Thierry]

Hello Job75

Ah ben ca me rassure on fait tous les deux "pipi dans le violon" LoL, avec ton code, idem, NADA ! sur les classeurs Cibles de @Benes !

Bon au moins ca me rassure !
@+Thierry

 

[job75]

Quel violon ? Mon code fonctionne sans problème, comme indiqué je l'ai testé.

Il faut bien sûr que les fichiers de destination aient été créés avec les noms indiqués dans le code...

 

[_Thierry]

Re Job,

Si tu utilises vraiment le vrai fichier de @Benes "BAC-PRO-MELEC-Grilles-Eval-CCF-NOM_Prénom-juin-2020.xlsx" (dans "PourForum.zip" que l'on peut ouvrir avec 7zip une fois renommé en .rar) , non seulement la feuille est protégée, mais ça j'ai ajusté ton code, mais on n'arrive pas à sauver les noms et prénoms, tout comme moi avec mon code !
Avec des classeurs tout neufs il n'y a pas de souci !

Donc oui le même violon, on va monter un orchestre philharmonique LoL !

Il y a des Gremlins là-dedans !
Bien, à toi
@+Thierry

 

[Benes]

Bonsoir messieurs
Encore mille merci d'avoir pris le temps de m'aider.
J'ai examiné ton dernier code Job75, je n'y ai pas compris grand chose, mon niveau est nettement en dessous, du coup pour l’interpréter et l'adapter j'ai pas pu.
Pas grave je me suis dis, je vais le lancer comme ça et si ça marche, dommage pour la compréhension mais au moins j'aurais ce qu'il me faut.
Malheureusement, je l'ai lancé et rien.
J'ai essayé 2 ou 3 trucs mais sans vraiment savoir se que je faisais je n'ai pas réussi le faire tourner.
Je vois bien que c'est moi qui déconne vu que Thierry a réussi a le lancer.
Bref de toute façon il semble qu'il y ai un souci vu que Thierry nous explique que ça ne rempli pas les cellules comme désiré. Du coup je ne pouvais en rester là et j'ai suivie ton conseil Job75, j'ai codé pour ouvrir, remplir, fermer le fichier et vous savez quoi, j'ai réussi!!!
Je ne suis pas peu fier, j'y ai passé la journée mais ça marche!!
Avec mon fichier BEP, CAP et même mon fichier BAC qui il est vraie semble bizarre. HEUREUX!!
Je vous envoie mon petit bout de code au cas ou une suggestion.
En tous cas merci encore

 

[_Thierry]

Bonsoir @Benes, @job75, le Forum

Heureux et content pour toi aussi d'avoir su te dépanner, c'est comme ceci qu'on apprend le mieux.

PS, dans ton zip, il ne me semble pas voir la macro "Traiter" du second nouveau bouton, mais si ca fonctionne alors tant mieux.

Bonne soirée
@+Thierry

 

[job75]

Bon maintenant passons à la méthode ADO avec ce code :

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

Avec 100 fichiers de destination il s'exécute chez moi en 13 secondes.

Pour tester téléchargez les 3 fichiers joints dans le même dossier (le bureau).

 

[job75]

Vous pouvez noter qu'avec la méthodes ADO on peut remplir les cellules de la feuille de destination même si elle est protégée avec mot de passe.

Bonne nuit.

 

[Benes]

Merci Job75
Effectivement ça marche mais avec les fichiers que tu as joint (qui porte le bon nom mais qui ne sont pas les original que j'avais joins. Avec elles ça ne marche pas). Sans doute un petit détail a ajuster. Je garde ton code sous le coude au cas ou un jours... Pour l'instant c'est tout bon pour moi, ma petite routine met moins d'une seconde par fiche et ça me va très bien. Dommage pour ADO mais tu avais raison ouvrir et fermer le fichier c'est pas la mer a boire tant que je n'ai pas 1000 fiches a traiter.
Encore merci pour ton temps.

 

[_Thierry]

ça marche mais avec les fichiers que tu as joint (qui porte le bon nom mais qui ne sont pas les original que j'avais joins.

Bonjour à tous !

Comme je dis depuis pas mal de posts, il y a des Gremlins dans ces fichiers !!! Et nous on joue du violon !! LoL

Bon weekend
@+Thierry

 

[job75]

Bonjour Benes, _Thierry,

Dans ce fichier (2) j'ai remplacé On Error Resume Next par le test If Dir(fich) <> "" Then.

Avec 100 fichiers, méthode classique => 16 secondes, méthode ADO => 4,6 secondes.

Pourquoi faire la fine bouche sur ADO, c'est quand même mieux non ?

A+

 

[dysorthographie]

bonjour,
je me suis inspiré tu travail de JOB75!
j'ai apporté quelque modification pas bien méchante!

si ça inspire!

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

 

[job75]

Bonjour dysorthographie,

j'ai apporté quelque modification pas bien méchante!

Chez vous ces modifications fonctionnent ? Chez moi il y a bug sur Cd.Execute.

A+

 

[dysorthographie]

Je vais faire un teste sur une autre machine