Hello,
This code is to fetch data from an external Excel file that works efficiently. I just want to add copying the value of one cell to the file, which is the cell ("H9")
This code is to fetch data from an external Excel file that works efficiently. I just want to add copying the value of one cell to the file, which is the cell ("H9")
VBA Code:
Sub imprtdonnéesplusieursfichiers()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
'on Désactive le presse papier et la raffraich écran
Application.ScreenUpdating = False
Application.CutCopyMode = False
'effece anciennes données
Range("B18:I100000").Value = ""
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Examen") 'définit l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "note*.xlsx?") 'définit le premier fichier excel F commençant par "export" ayant CA comme chemin d'accès
Do While F <> "" 'exécute tant qu'il existe des fichiers F
If Not F = CD.Name Then 'si F est différent du nom du fichier destination
Set CS = Workbooks.Open(CA & F) 'définit le classeur source CS en l'ouvrant
Set OS = CS.Worksheets("NotesEX") 'définit l'onglet source OS
'définit la cellule de destination DEST (c18 si B18 est vide sinon la première cellule vide de la colonne C de l'onglet OD)
Set DEST = IIf(OD.Range("C18").Value = "", OD.Range("C18"), OD.Cells(Application.Rows.Count, "C").End(xlUp).Offset(1, 0))
OS.Range("C18:F118").Copy DEST 'copie la plage C18:F118 de l'onglet source et le colle dans DEST
CS.Close False 'ferme le classeur source sans enregistrer
F = Dir 'définit le prochain fichier F commençant par "export" ayant CA comme chemin d'accès
End If 'fin de la condition
Loop 'boucle
OD.Activate 'active l'onglet OD
Application.ScreenUpdating = True
Application.CutCopyMode = True
End Sub