VBA : Modification d'une macro pour selection de fichier
Bonjour à tous
Je suis actuellement en train de plancher sur une macro qui me permettrait de récupérer les données de l'onglet "Recap" de plusieurs fichiers Excel situés dans un répertoire. Les noms des fichiers est obligatoirement différents (pas de fichier1, fichier2 par exemple mais plutôt "controle_agent41_octobre", "controle_agentXU_octobre", la nomenclature change en fonction de l'auteur du fichier...)
J'ai plusieurs répertoires fonctionnant de cette façon. Cela concerne une consolidation mensuelle de différents "contrôle qualité" de plusieurs services tout simplement.
Pour l'instant (et grâce ) au site wikiversity, j'ai choppé cette macro que j'ai adapté à mon besoin.
Sub consolidation_regroupement()
'Stoppe l'actualisation de l'écran. Cela sert à masquer les actions de la macro
Application.ScreenUpdating = False
'Détermine le chemin d'accès aux fichiers
Dim chemin As String
Dim fichier As String
Dim extension As String
chemin = "D:\Downloads\test\"
fichier = "test"
extension = ".xlsx"
'Indique le nombre de fichiers à consolider
nbfichiers = 2
For i = 1 To nbfichiers
'Ouvre le fichier à consolider
Workbooks.Open (chemin & fichier & i & extension)
'Sélectionne la feuille où se trouvent les données
Sheets("Recap").Select
'Compte le nombre de lignes à copier
n = WorksheetFunction.CountA(Range("B:B"))
'Compte le nombre de colonnes à copier
m = ActiveSheet.UsedRange.Columns.Count
'Copie les données
Range(Cells(2, 1), Cells(n, m)).Copy
'Active le classeur de synthèse
'Windows("Synthese.xlsm").Activate
ThisWorkbook.Activate
'Sélectionne la feuille où on va coller les données
Sheets("Recap2").Select
'Compte le nombre de lignes non vides et ajoute 1 pour avoir le numéro de la première ligne vide
c = WorksheetFunction.CountA(Range("A:A")) + 1
'Sélectionne la première cellule vide
Range("A" & c).Select
'Colle les données
ActiveSheet.Paste
'Ferme la base de données qui a été consolidée et passe à la suivante
Windows(fichier & i & extension).Close
Next i
'Réactive l'actualisation de l'écran
Application.ScreenUpdating = True
End Sub
Elle fait ce dont j'ai besoin, à savoir mettre dans l'onglet du classeur utilisé les données des fichiers spécifiés dans la macro.
Le probleme c'est que les indications sont entrées "en dur" dans la macro, ce qui est finalement pas pratique à utiliser.
chemin = "D:\Downloads\test\"
fichier = "test"
extension = ".xlsx"
'Indique le nombre de fichiers à consolider
nbfichiers = 2
For i = 1 To nbfichiers
Du coup, j'ai cherché comment remplacer le problème de selection de répertoire ainsi que de selection de fichiers (noms différents et l'extension pourrait également être hétérogène).
Voici les codes que j'ai pu dénicher sur gcexcel :
1 - Faire apparaître une fenêtre de sélection de répertoire qui m'intéresse :
Function ChoisirRepertoire() As String
Dim oFolder As Object
ChoisirRepertoire = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choisir un répertoire", 0)
If (Not oFolder Is Nothing) Then ChoisirRepertoire = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
2 - Sélection multiples de fichiers :
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function
Mais impossible à tout mettre en mettre en place, ca foire car la macro de base à besoin d'un nom de fichier et du nom de répertoire (en l'etat, la sélection de répertoire n'inclut pas le "\", ce qui semble causer une erreur).
Et enfin, lorsque j'utilise la macro sans aucune modification sale de ma part, je tombe sur ce message à chaque fichier ouvert
C'est possible de le faire disparaitre?
Est ce que quelqu'un pourrait me filer un coup la dessus s'il vous plait ?
Merci beaucoup !
Salut Kev,
Tu peux tenter un
Application.DisplayAlerts = False
Tu ne devrais plus avoir ce message mais par contre ton presse papier va grossir de plus en plus.
N'oublie pas de le remettre à true à la fin de la macro
Sinon tu vide toi même le presse papier, je n'ai pas cherché plus que ça mais avec le code suivant cela le fait:
Application.CutCopyMode = False
Il y a un sujet sur le site déjà il me semble :
https://forum.excel-pratique.com/excel/vider-le-presse-papiers-avec-vba-t16185.html
ECG
Salut
Voici le code trouvé pour vider le presse papier
Sub ViderPressePapier()
'Nécéssite d'activer la référence "Microsoft Forms 2.0 Object Library."
Dim Cible As dataObject
Set Cible = New dataObject
Cible.setText ""
Cible.putInClipboard
Set Cible = Nothing
End Sub
La référence est déjà active dans ma configuration d'Excel, je n'ai plus qu'a ajouter cet appel en fin de marcro !
Merci! J'y insert le message pour stopper les avertissements et voila ca passe !
edit : bon finalement
Application.CutCopyMode = False
fonctionne tres bien, l'autre code me dit que la "Cible As dataObject" est un type défini non défini par l'utilisateur.
Bref, le probleme du presse-papier est réglé !
Bon je ne sais pas si on avance mais on en est la
'module de taf au 20-11-17
Sub consolidation_regroupement_test()
'Stoppe l'actualisation de l'écran. Cela sert à masquer les actions de la macro
Application.ScreenUpdating = False
'On supprime le message concernant le presse papier
Application.CutCopyMode = False
' Supprime l'alerte concernant les donnees du presse-papier
Application.DisplayAlerts = False
Application.CutCopyMode = False
'Détermine le chemin d'accès aux fichiers
Dim chemin As String
Dim fichier As String
Dim extension As String
chemin = "C:\ZONE06\test\"
fichier = "test"
extension = ".xlsx"
'Indique le nombre de fichiers à consolider (donc fichier1 puis fichier2 etc)
nbfichiers = 2
For i = 1 To nbfichiers
'Ouvre le fichier à consolider
Workbooks.Open (chemin & fichier & i & extension)
'Sélectionne la feuille où se trouvent les données
Sheets("Recap").Select
'Compte le nombre de lignes à copier
N = WorksheetFunction.CountA(Range("B:B"))
'Compte le nombre de colonnes à copier
m = ActiveSheet.UsedRange.Columns.Count
'Copie les données
Range(Cells(2, 1), Cells(N, m)).Copy
'Active le classeur de synthèse
'Windows("Synthese.xlsm").Activate
ThisWorkbook.Activate
'Sélectionne la feuille où on va coller les données
Sheets("Recap2").Select
'Compte le nombre de lignes non vides et ajoute 1 pour avoir le numéro de la première ligne vide
c = WorksheetFunction.CountA(Range("A:A")) + 1
'Sélectionne la première cellule vide
Range("A" & c).Select
'Colle les données
ActiveSheet.Paste
'Ferme la base de données qui a été consolidée et passe à la suivante
Windows(fichier & i & extension).Close
Next i
'Réactive l'actualisation de l'écran
Application.ScreenUpdating = True
End Sub
mais ca bug sur
'Ferme la base de données qui a été consolidée et passe à la suivante
Workbooks(Selectionner_Fichiers(i)).Close
Next i
en me disant que : L'indice n'appartient pas à la selection
meme constat avec
'Ferme la base de données qui a été consolidée et passe à la suivante
Windows(fichier & i & extension).Close
Next i
C'est... compliqué !
Salut,
Tu as un peu avancé c'est déja bien
Tu avais le bug avant ou c'est tout nouveau?
Tu as juste un soucis de boucles/indices par rapport au nom de tes fichiers
tu as bien tes fichiers :
"C:\ZONE06\test\test1.xlsx" et "C:\ZONE06\test\test2.xlsx" qui existent? au bon endroit avec les bonnes majuscules/minuscules?
Tu ne les ouvres pas toi même avant quand tu test la macro? si c'est déjà ouvert je pense que ça fait une erreur ^^
Edit: essaye aussi avec "c:" et pas "C:", je ne sais pas si c'est sensible à la casse sur le chemin d'accès hmm
ECG
C'est bon, la ça fonctionne
Sub consolidation_regroupement_Jo()
'Stoppe l'actualisation de l'écran. Cela sert à masquer les actions de la macro
Application.ScreenUpdating = False
'On supprime le message concernant le presse papier
Application.CutCopyMode = False
sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
For i = LBound(Selectionner_Fichiers) To UBound(Selectionner_Fichiers)
'Ouvre le fichier à consolider
Workbooks.Open (Selectionner_Fichiers(i))
'Sélectionne la feuille où se trouvent les données
Sheets("Recap").Select
'Compte le nombre de lignes à copier
N = WorksheetFunction.CountA(Range("B:B"))
'Compte le nombre de colonnes à copier
m = ActiveSheet.UsedRange.Columns.Count
'Copie les données
Range(Cells(2, 1), Cells(N, m)).Copy
'Active le classeur de synthèse
'Windows("Synthese.xlsm").Activate
ThisWorkbook.Activate
'Sélectionne la feuille où on va coller les données
Sheets("Recap2").Select
'Compte le nombre de lignes non vides et ajoute 1 pour avoir le numéro de la première ligne vide
c = WorksheetFunction.CountA(Range("A:A")) + 1
'Sélectionne la première cellule vide
Range("A" & c).Select
'Colle les données
ActiveSheet.Paste
'Ferme la base de données qui a été consolidée et passe à la suivante
Workbooks(Dir(Selectionner_Fichiers(i))).Close
Next i
'Réactive l'actualisation de l'écran
Application.ScreenUpdating = True
'On supprime le message concernant le presse papier
Application.CutCopyMode = False
End Sub
Le seul probleme : la gestion du presse papier, le message s'affiche de nouveau !
Salut,
Hmm le
Application.CutCopyMode = False
ne supprime pas les messages du presse papier, ça le vide surtout dans notre cas, il faudrait regarder à nouveau l'aide d'excel pour savoir en détail.
Bref et avec un
Application.DisplayAlerts = False
en début de code, cela dit quoi?
ECG
Salut, désolé du temps de réponse, la semaine fut chargée de ouf, la fin de l'année arrivant à grand pas, il faut tout mettre en place pour la nouvelle année dans l'urgence (comme tous les ans...
Bon voila la version pratiquement définitive
Sub consolidation_regroupement()
'Stoppe l'actualisation de l'écran. Cela sert à masquer les actions de la macro
Application.ScreenUpdating = False
Selectionner_Fichiers = Application.GetOpenFilename("Fichiers Excel (*.xls*), *.xls*,Tous (*.*),*.*", 1, "Sélectionnez les fichiers", "Ouvrir", True)
'feuille de destination
Set dstsheet = ThisWorkbook.Sheets("Recap2")
For i = LBound(Selectionner_Fichiers) To UBound(Selectionner_Fichiers)
'Ouvre le fichier à consolider
Set x = Workbooks.Open(Selectionner_Fichiers(i))
'on vérifie que l'onglet 'recap' existe
sheetExists = False
For Each csheet In Worksheets
If LCase(csheet.Name) = "recap" Then
sheetExists = True
Exit For
End If
Next csheet
If sheetExists = False Then
Workbooks(Dir(Selectionner_Fichiers(i))).Close
MsgBox "L'onglet Recap n'existe pas dans " & Selectionner_Fichiers(i), vbOKOnly + vbExclamation, "Attention!"
Else
'feuille source
Set srcsheet = x.Sheets("Recap")
'Compte le nombre de lignes à copier
N = Application.WorksheetFunction.CountA(srcsheet.Range("B:B"))
'Compte le nombre de colonnes à copier
m = srcsheet.UsedRange.Columns.Count
'Compte le nombre de lignes non vides et ajoute 1 pour avoir le numéro de la première ligne vide
c = WorksheetFunction.CountA(dstsheet.Range("A:A")) + 1
'Copie
dstsheet.Range(dstsheet.Cells(c, 1), dstsheet.Cells(c + N - 1, m)).Value = srcsheet.Range(srcsheet.Cells(2, 1), srcsheet.Cells(N + 1, m)).Value
'Ferme la base de données qui a été consolidée et passe à la suivante
Workbooks(Dir(Selectionner_Fichiers(i))).Close
End If
Next i
'Réactive l'actualisation de l'écran
Application.ScreenUpdating = True
End Sub
elle doit etre enregistrée dans le fichier XLSM (et non pas dans son fichier perso de macro).
La elle fonctionne, merci à mon cousin !
Je laisse à dispo pour tout ceux qui auront le même besoin que besoin (qui semble être fréquent d'ailleurs!).
Merci les mecs pour votre aide également !