Utiliser un fichier source qu'une seule fois
Bonjour à tous,
Je me permets de solliciter votre aide pour une macro.
Tout d'abord voici le code :
Sub TEST()
Dim FSO As Object
Dim SubFolder As Object
Dim Fichier As Object
Dim CH As String
Dim OD As Worksheet
Dim CS As Workbook
Dim OS As Worksheet
Dim F As String
Dim Name As String
Application.DisplayAlerts = False
CH = "M:\Déclaration HMO\Année 2021\"
Set FSO = CreateObject("Scripting.Filesystemobject")
On Error Resume Next
For Each SubFolder In FSO.getfolder(CH).subfolders
For Each Fichier In SubFolder.Files
Set OD = ThisWorkbook.Worksheets(1)
Set CS = Workbooks.Open(Fichier)
Set OS = CS.Worksheets(1)
If OS.Range("$B$4") <> "" Then 'copie toutes les valeurs pour le groupe 3 article 1
DerLA = OD.Range("H" & Rows.Count).End(xlUp).Row + 1
OS.Range("$B$4").Copy
OD.Range("H" & DerLA).PasteSpecial xlPasteValues 'copie de l'article
OS.Range("$B$1").Copy
OD.Range("A" & DerLA).PasteSpecial xlPasteValues 'copie de la date
OS.Range("$AH$1").Copy
OD.Range("F" & DerLA).PasteSpecial xlPasteValues 'copie de l'équipe
OS.Range("$B$3").Copy
OD.Range("G" & DerLA).PasteSpecial xlPasteValues 'copie du groupe
If Not OS.Range("$B$38").Value <> "" Then 'si nb AP est vide alors NMO = 0
OD.Range("I" & DerLA) = ""
Else
OD.Range("I" & DerLA) = OS.Range("$B$38").Value - OS.Range("$C$38")
End If
OD.Range("J" & DerLA) = OS.Range("$B$5").Value * OS.Range("$B$38").Value 'calcule HD
OD.Range("K" & DerLA) = OS.Range("$B$13").Value * OS.Range("$B$38").Value 'calcule HU
OD.Range("L" & DerLA) = OS.Range("$B$15").Value * OS.Range("$B$38").Value 'calcule HP
OS.Range("$B$25").Copy
OD.Range("M" & DerLA).PasteSpecial xlPasteValues 'copie hL/palette
OS.Range("$B$29").Copy
OD.Range("N" & DerLA).PasteSpecial xlPasteValues 'copie hL
OS.Range("$B$31").Copy
OD.Range("O" & DerLA).PasteSpecial xlPasteValues 'copie le rendement
OS.Range("$B$32").Copy
OD.Range("P" & DerLA).PasteSpecial xlPasteValues 'copie le TRS
End If
CS.Close False
Next Fichier
Next SubFolder
Application.DisplayAlerts = True
End SubC'est un code basique qui me permet d'aller dans les sous répertoire et de copier coller des informations du classeur source vers mon classeur destination.
Le code fonctionne, cependant ma question est la suivante : est-il possible d'utiliser un classeur source qu'une seule fois ?
En gros je dispose d'un répertoire avec 52 sous-répertoires qui sont les semaine de l'année. Dans ces sous-répertoires je dispose d'une vingtaine de classeur. Donc je copie colle les informations qui sont dans ce classeur. Le problème est que le répertoire est mise à jour toutes les semaines, donc chaque semaine les vingtaines de classeur sont déposés dans les sous-répertoires.
Donc actuellement j'ai copié jusqu'à la semaine 17 et je voudrais JUSTE copier la semaine 18 mais malheureusement la macro se lance depuis le début et cela met énormément de temps. Comment puis-je utiliser un fichier ou même un sous-répertoire qu'une seule fois ? En gros juste faire une "mise-à-jour" pour ne copier les informations issu du sous-répertoire 18.
Je vous remercie d'avance.
Bonjour Zalee,
Comment les fichiers sont-ils nommés ? Car si le numéro de semaine n'est pas contenu dans l'intitulé de fichier, je ne vois malheuresement pas d'autre solutions que d'ouvrir 1 à 1 les fichiers pour regarder à quelle semaine correspondent-t-il et dans ce cas le temps d'execution seras long.
Après le seul moyen d'écourter sera de trouver une solution pour ne pas éxecuter le code si le numéro de semaine à déja été traité mais visiblement c'est vraiment l'ouverture et la fermetture des classeurs qui alonge le temps d'éxecution
A+
EDIT: Sinon une solution pourrait être de stocker le nom de chaque fichier après qu'il est été traité sur ton classeur, de ce fait la macro sait si elle à déja traité ce fichier/semaine et donc ne perd pas de temps à l'ouvrir.
Bonjour Gabin et merci pour ton retour.
Les fichiers sont nommés de la façon qui suit : AAAAMMJJ# avec # la lettre de l'équipe (A,B,C).
Re,
j'ai édité mon précédent message je ne sais pas si t'as vu.
J'ai pensé à cette solution qui me semble adapté qu'en penses tu ?
Tu pourrais avoir un onglet masqué sur ton excel qui contient ces données
Merci Gabin je viens de voir à l'instant.
En partant de ton idée, si je ferme le classeur destination et l'ouvre à nouveau, les classeurs sources déjà utilisés seront toujours stockés dans la mémoire ?
EDIT: je viens de penser, n'est-il pas possible de faire une sélection multiple à partir d'une boite de dialogue ? Ce qui me permettrait de choisir les classeurs à utiliser.
En partant de ton idée, si je ferme le classeur destination et l'ouvre à nouveau, les classeurs sources déjà utilisés seront toujours stockés dans la mémoire ?
Je pensais utiliser le classeur de départ, celui qui contient la macro comme mémoire, avec par exemple un onglet dédié qui serait masqué de l'utilisateur.
EDIT: je viens de penser, n'est-il pas possible de faire une sélection multiple à partir d'une boite de dialogue ? Ce qui me permettrait de choisir les classeurs à utiliser.
SI bien sûr, voici un début de code pour avoir une selection multiple:
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Title = "Titre de la fenêtre"
.InitialFileName = "Par défaut ou si le chemin est incorrect: Mes documents"
.Show
If .SelectedItems.Count = 0 Then
exit sub
End If
For i = 1 To .SelectedItems.Count
Call LaProcedure(.SelectedItems(i))
Next i
End WithDans ce code, j'éxecute pour tous les fichiers sélectionné une procédure qui a pour argument un fichier
Vois ce que tu peux bricoler de ça peut être ! :)
Merci beaucoup Gabin je vais essayer ton idée.
Simple question concernant ton idée qui m'a l'air pas mal.
Comment pourrais-je procéder ? As-tu un bout de code ?
Imaginons que tu as un onglet "ListeFichiersTraites" qui peut être masqué pour plus d'esthétisme.
dim trouve as boolean
dim cel as range
On Error Resume Next
For Each SubFolder In FSO.getfolder(CH).subfolders
For Each Fichier In SubFolder.Files
with Thisworkbook.sheets("ListeFichiersTraites")
trouve = false
for each cel in range("A1", Range("A1").End(xlDown))
if cel.value = Fichier.path then
trouve = true
exit for
end if
next cel
end with
If trouve = false then
[... Le code...]
end If
Next Fichier
Next SubFolder
Application.DisplayAlerts = True
End SubOk voici une idée de code en espérant que tu comprennes l'idée, J'ai écrit le code sans le testé donc on est pas à l'abri de petites coquilles ^^'
Pour une meilleure visibilité j'ai enlevé le gros de ton code donc à réadapter sans le copier coller tel quel
Tiens moi au jus de si ça fonctionne :)
Ton idée n'est vraiment pas mal d'autant plus que ça pourrait m'arranger d'avoir la liste des fichiers dans un onglet.
Le problème est que le code ne fonctionne pas et je ne sais pas pourquoi car ça bug et ferme excel à chaque fois.
Je vais essayer de chercher un peu plus le problème et je reviens vers toi.
Merci encore
Le problème est que le code ne fonctionne pas et je ne sais pas pourquoi car ça bug et ferme excel à chaque fois.N'hésite pas à utiliser la touche F8 pour éxecuter pas à pas le programme est voir ou ca plante !
bon courage
Bonjour Zalee, salut Gabin !
Autre suggestion : demander la saisie du numéro de semaine recherché et contrôler que le nom du répertoire contient bien ce numéro (ex : Dossier semaine 24).
Sub TEST()
Dim FSO As Object, SubFolder As Object, Fichier As Object
Dim CH As String, F As String, Sem As String
Dim OD As Worksheet, CS As Workbook, OS As Worksheet
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
CH = "M:\Déclaration HMO\Année 2021\"
Set FSO = CreateObject("Scripting.Filesystemobject")
Set OD = ThisWorkbook.Worksheets(1)
Sem = InputBox("Numéro de semaine à intégrer ?", "N° semaine")
On Error Resume Next
For Each SubFolder In FSO.getfolder(CH).subfolders 'Boucle sur les sous-répertoires
If SubFolder.Name Like "* " & Sem & "*" Then 'Contrôle du nom du répertoire
For Each Fichier In SubFolder.Files 'Boucle sur les fichiers
Set CS = Workbooks.Open(Fichier)
Set OS = CS.Worksheets(1)
If OS.Range("$B$4") <> "" Then 'copie toutes les valeurs pour le groupe 3 article 1
DerLA = OD.Range("H" & Rows.Count).End(xlUp).Row + 1
OD.Range("H" & DerLA) = OS.Range("$B$4") 'copie de l'article
OD.Range("A" & DerLA) = OS.Range("$B$1") 'copie de la date
OD.Range("F" & DerLA) = OS.Range("$AH$1") 'copie de l'équipe
OD.Range("G" & DerLA) = OS.Range("$B$3") 'copie du groupe
If Not OS.Range("$B$38").Value <> "" Then 'si nb AP est vide alors NMO = 0
OD.Range("I" & DerLA) = ""
Else
OD.Range("I" & DerLA) = OS.Range("$B$38").Value - OS.Range("$C$38")
End If
OD.Range("J" & DerLA) = OS.Range("$B$5").Value * OS.Range("$B$38").Value 'calcule HD
OD.Range("K" & DerLA) = OS.Range("$B$13").Value * OS.Range("$B$38").Value 'calcule HU
OD.Range("L" & DerLA) = OS.Range("$B$15").Value * OS.Range("$B$38").Value 'calcule HP
OD.Range("M" & DerLA) = OS.Range("$B$25") 'copie hL/palette
OD.Range("N" & DerLA) = OS.Range("$B$29") 'copie hL
OD.Range("O" & DerLA) = OS.Range("$B$31") 'copie le rendement
OD.Range("P" & DerLA) = OS.Range("$B$32") 'copie le TRS
End If
CS.Close False
Next Fichier
End If
Next SubFolder
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End SubPS : j'ai légèrement retravaillé le code, notamment pour virer les copié-collé inutiles, car seules les valeurs sont rapatriées.
Bonjour Pedro,
Merci pour ton code, je l'ai essayer mais bizarrement il ouvre le classeur mais ne copie rien du tout.
J'ai rajouté les ligne "copy" et la ça marche parfaitement.
Si je peux te poser une question, comment pourrais-je faire pour une sélection multiple avec une boite de dialogue ?
Celle de Gabin me plante au niveau de Call "Sub ou function non définie"
Merci d'avance
Zalee, mon code est à adapter.
à la ligne:
Call LaProcedure(.SelectedItems(i))C'est juste un exemple de ce que l'on peu faire, si tu n'as aucunes procédures nommées LaProcedure forcément cela ne marcheras pas !
tu pourrais par exemple remplacer cette ligne par:
Set CS = ActiveWorkbook
Set OS = CS.Worksheets(1)
If OS.Range("$B$4") <> "" Then 'copie toutes les valeurs pour le groupe 3 article 1
DerLA = OD.Range("H" & Rows.Count).End(xlUp).Row + 1
OD.Range("H" & DerLA) = OS.Range("$B$4") 'copie de l'article
OD.Range("A" & DerLA) = OS.Range("$B$1") 'copie de la date
OD.Range("F" & DerLA) = OS.Range("$AH$1") 'copie de l'équipe
OD.Range("G" & DerLA) = OS.Range("$B$3") 'copie du groupe
If Not OS.Range("$B$38").Value <> "" Then 'si nb AP est vide alors NMO = 0
OD.Range("I" & DerLA) = ""
Else
OD.Range("I" & DerLA) = OS.Range("$B$38").Value - OS.Range("$C$38")
End If
OD.Range("J" & DerLA) = OS.Range("$B$5").Value * OS.Range("$B$38").Value 'calcule HD
OD.Range("K" & DerLA) = OS.Range("$B$13").Value * OS.Range("$B$38").Value 'calcule HU
OD.Range("L" & DerLA) = OS.Range("$B$15").Value * OS.Range("$B$38").Value 'calcule HP
OD.Range("M" & DerLA) = OS.Range("$B$25") 'copie hL/palette
OD.Range("N" & DerLA) = OS.Range("$B$29") 'copie hL
OD.Range("O" & DerLA) = OS.Range("$B$31") 'copie le rendement
OD.Range("P" & DerLA) = OS.Range("$B$32") 'copie le TRS
End If
CS.Close FalseJ'ai utilisé le code de Pedro (Bonjour Pedro22 ! ) je ne sais pas si il fonctionne du coup ?
Bonjour Gabin, un grand merci à toi,
Que suis-je bête, j'aurais du penser à remplacer Call par ma macro.
Chose faite, je suis face à un nouveau problème, dès la première ligne j'ai l'erreur 2015. J'ai fait des recherches mais je ne comprends pas vraiment comment y remédier.
If OS.Range("$B$4") <> "" Then 'copie toutes les valeurs pour le groupe 3 article 1Autre chose n'est-il pas possible de spécifier le classeur source CS par autre chose que activeworkbook car je crois qu'il y a confusion et la macro copie mon classeur destination dans mon classeur destination.
EDIT: en fait je viens de voir, lorsque que je sélectionne les classeurs sources ces derniers ne s'ouvrent pas avec le code, j'ai rajouté Workbooks.open(i) mais ça ne donne rien. Comment faire pour ouvrir les classeurs sélectionner un par un ?
Merci d'avance
Bonjour,
Essaie en précisant .Value ou .Text :
If OS.Range("$B$4").Value <> "" Then 'copie toutes les valeurs pour le groupe 3 article 1Bonjour Zalee, Pedro,
Zalee tu as bien SelectedItem en argument de la procédure ?
SI oui tu as du donné un nom à cette argument donc essaye comme cela:
Workbooks.Open Filename:= ArgumentSInon autre solution qui devrais fonctionner, juste avant d'appeler t'as procédure avec Call tu fait:
Workbooks.Open Filename:= .SelectedItems(i)Du coup ce sera bien ton fichier qui sera Actif pour le mettre dans une variable au début de la procédure.
J'espère que je suis pas trop brouillon dans mes explications :x
A+
Un grand merci à vous, le problème venait en effet de l'argument.
Gabin tu n'est pas brouillon simplement je suis un amateur donc ça complique les choses parfois.
En tout cas je vous remercie énormément.
Voici le code complet
Dim FSO As Object, SubFolder As Object, Fichier As Object
Dim CH As String, F As String, Sem As String
Dim OD As Worksheet, CS As Workbook, OS As Worksheet
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error Resume Next
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Title = "Titre de la fenêtre"
.InitialFileName = "Par défaut ou si le chemin est incorrect: Mes documents"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
End If
For i = 1 To .SelectedItems.Count
Set CS = Workbooks.Open(.SelectedItems(i))
Set OS = CS.Worksheets(1)
Set OD = ThisWorkbook.Worksheets(1)
Le code [...]
Next i
End With
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomaticPetite remarque, tu peux sortir la définition de la variable OD de la boucle, car c'est toujours la même :
Set OD = ThisWorkbook.Worksheets(1)Merci Pedro, je vais le faire d'autant plus que j'ai repris ce que tu as dis, j'ai remplacé par value mes lignes et du coup j'ai enlevé toutes les lignes de copy.
Merci beaucoup !
Merci du retour Zalee,
Bonne journée à tous !