Copie ligne dans BDD
Bonjour à tous,
1 - Dans un dossier (CRF2021), j'ai plusieurs excel (Formulaire), tous de meme type, seul le titre change. Sans chaque fichier j'ai fais une BDD afin d'extraire toujours les mêmes données dans un tableau avec une seule ligne.
2- J'ai un fichier nommé BDD-CRF ou je souhaite récupérer la ligne de l'onglet "BDD" de tous les fichiers du dossier CRF2021.
J'utilise la macro suivante :
'Chemin des fichiers
ChDir "C:\Users\XXX\Downloads\CRF2021"
'Selection des fichier .xlsm
NomClasseur = Dir("C:\Users\XXX\Downloads\CRF2021\*.xlsm")
While Len(NomClasseur) > 0
Application.DisplayAlerts = False
Workbooks.Open NomClasseur 'Ouverture classeur
Sheets("BDD").Activate 'Sélection Feuille à copier.
Range("A2:AS2").Copy 'Copie la ligne de la feuille
Workbooks("BDD-CRF.xlsm").Activate 'Retour sur la feuille "BDD"
MaNouvelleLigne = ActiveSheet.UsedRange.Rows.Count + 1
Range("A" & MaNouvelleLigne).Select 'Position A dans le classeur destination.
ActiveSheet.Paste 'Copie les données du fichier source
Range("A" & MaNouvelleLigne & ":A" & ActiveSheet.UsedRange.Rows.Count) = NomClasseur 'Indication du nom du fichier
Workbooks(NomClasseur).Close 'Fermeture du classeur source
NomClasseur = Dir 'Boucle sur le prochain classeur.
Wend
Columns("A:A").Replace ".xlsm", "" 'Suppression l'extension des classeurs
MsgBox "La copie est terminée."
Application.ScreenUpdating = False
End Sub
Tout fonctionne correctement, la BBD-CRF se rempli bien, à ceci près :
Lorsque j'ai 5 fichiers, il me recupère bien les 5 lignes, mais au lieu de coller la ligne, il m'ajoute +1. Du coup je me retrouve avec des décalages de +1 pour le second, +2 pour le troisième........
Auriez-vous une idée afin qu'il me copie la seule ligne sans faire +1 à chaque fois et décaler toutes les données ?
Autre petite question, quelle serait le code pour qu'il vérifie s'il y a des modifications et si oui qu'il fasse uniquement un update des infos.
Merci de votre aide
Bonjour,
Je suppose que vous avez toujours des données dans chaque fichier en A2:AS2 ?
Quel est le nom de la feuille Activesheet dans votre fichier BDD-CRF
Possible de voir votre fichier BDD-CRF sans données confidentielles ?
Cordialement
Bonjour Dan,
Je suppose que vous avez toujours des données dans chaque fichier en A2:AS2 ?
OUI, la ligne se remplit à chaque fois que les les données du formulaire se remplissent
Quel est le nom de la feuille Activesheet dans votre fichier BDD-CRF
Le meme "BDD-CRF"
En PJ le fichier
Merci
Au début, le code n'est pas tout à fait le même que ce que vous avez posté.
essayez comme ceci :
Sub ConsoliderClasseurs()
Dim NomClasseur as Workbook
Application.ScreenUpdating = False
'____________________________________________________________________________
' Parcours de tous les fichiers
'____________________________________________________________________________
'Chemin des fichiers
ChDir "C:\Users\SLE\Downloads\CRF2021"
'Selection des fichiers .xlsm
NomClasseur = Dir("C:\Users\SLE\Downloads\CRF2021\*.xlsm")
While Len(NomClasseur) > 0
Application.DisplayAlerts = False
Workbooks.Open NomClasseur 'Ouverture classeur
With Workbooks("BDD-CRF.xlsm").Sheets("BDD-CRF")
MaNouvelleLigne = .UsedRange.Rows.Count + 1
ActiveWorkbook.Sheets("BDD").Range("A2:AS2").Copy .Range("A" & MaNouvelleLigne) 'Position A dans le classeur destination.
.Range("A" & .UsedRange.Rows.Count) = NomClasseur
End With
Workbooks(NomClasseur).Close 'Fermeture du classeur source
NomClasseur = Dir 'Boucle sur le prochain classeur.
Wend
Workbooks("BDD-CRF.xlsm").Sheets("BDD-CRF").Columns("A:A").Replace ".xlsm", "" 'Suppression l'extension des classeurs
MsgBox "La consolidation est terminée."
Application.ScreenUpdating = False
End Sub
Cordialement
Bonjour
Oui je viens de voir de vous avez déclaré les variables en en tête de module. Donc supprimez Dim As Workbook dans ce que je vous ai proposé.
Si vous n'avez que cette macro dans votre fichier, déplacez les 4 déclarations DIM juste en dessous de Sub ConsoliderClasseurs(). Il n'y a pas de raison de les mettre là où vous les avez actuellement
Par contre la déclaration pour "LigneTotal" peut être supprimée car elle ne fait pas partie de votre code.
Alors, l'extraction se fait bien, mais j'ai toujours ce decalage de ligne dans le BDD-CRF
J'ai deux fichiers à extraire, donc deux ligne à copier
Exemple sur le premier j'ai : ='[CR-2021-004.xlsm]PART 1 - INITIALISATION'!D9
et sur la seconde j'ai : ='[CR-20XX-YYY.xlsm]PART 1 - INITIALISATION'!D10
La seconde devrait utiliser la cellule D9.
J'ai donc toujours ce décalage de ligne
Pas sûr d'avoir bien compris la problématique je pense
Voulez que ce soit toujours sur D9 par exemple ? Pourquoi mettre +1 dans la définition de la variable Manouvelleligne ?
Afin de ne pas refaire l'existant j'ai trouvé un code ici --> https://codes-sources.commentcamarche.net/source/50983-ouvrir-tous-les-fichiers-excel-d-un-dossier-e...
Comme suit à vos fichiers reçus j'ai adapté votre code. Mettez ces deux codes dans un module à la place de l'autre.
Option Explicit
'NOTE : Pour utiliser ce code vous devez activer l'option "Microsoft Scripting Runtime" dans le menu Outils / References
Sub ConsoliderClasseurs()
' Macro à appeler dans votre classeur de macros
' Ouvre les fichiers Excel contenu dans un dossier et ses sous-dossiers
'
Dim Fso As Scripting.FileSystemObject ' Gestionnaire de fichiers Windows
Dim Nomdossiers As Scripting.Folders ' Collection des dossiers
Dim Nomfichiers As Scripting.Files ' Collection des fichiers
Dim ApplSelectionDossier As FileDialog ' Boite de dialogue d'ouverture de fichiers/dossiers
'Création de la boîte de dialogue de choix du dossier
Set ApplSelectionDossier = Application.FileDialog(msoFileDialogFolderPicker)
'Choix du dosiier
With ApplSelectionDossier
' Titre de la boite de dialogue
.Title = "Sélectionnez un dossier"
'L'utilisateur a cliqué sur le bouton OK de la boite de dialogue
If .Show = -1 Then
' Créer un objet de gestion des fichiers
Set Fso = CreateObject("Scripting.FileSystemObject")
' Affecte la liste des sous-dossiers du dossier sélectionné
Set Nomdossiers = Fso.GetFolder(.SelectedItems(1)).SubFolders
' Affecte la liste des fichiers du dossier en-cours
Set Nomfichiers = Fso.GetFolder(.SelectedItems(1)).Files
' Appel de la procédure d'ouverture des fichiers
Call Ouvrir_fichier(Nomdossiers, Nomfichiers)
'L'utilisateur a cliqué sur le bouton Annuler
Else
' Rien
'Fin si
End If
End With
End Sub
' Procédure de parcours de dossiers en mode récursif
Sub Ouvrir_fichier(Nomdossiers As Scripting.Folders, Nomfichiers As Scripting.Files)
Dim Nomdossier As Scripting.Folder ' Propriétés Dossier
Dim Nomfichier As Scripting.File ' Propriétés Fichier
Dim Fso As Scripting.FileSystemObject ' Gestionnaire de fichiers Windows
Dim ligne As Integer
Dim Nomclasseur As String
' S'il n'y a aps de fichiers dans le répertoire en cours
If Nomfichiers Is Nothing Then
' Rien
Else
' Pour chaque fichier de la liste de fichiers
For Each Nomfichier In Nomfichiers
' Si L'extension du fichier est .xls ou .xlsx (Excel)
If Right(Nomfichier, 5) = ".xlsm" Then 'Or Right(Nomfichier, 5) = ".xlsx"
' Ouvrir le fichier
Workbooks.Open Filename:=Nomfichier
' ****************** Votre macro ici ***********************************
With Workbooks("BDD-CRF.xlsm").Sheets("BDD-CRF")
On Error Resume Next
ligne = .Range("A:A").Find(ActiveWorkbook.Sheets("BDD").Range("A2"), LookIn:=xlValues, lookat:=xlWhole).Row
If ligne = 0 Then ligne = .UsedRange.Rows.Count + 1
On Error GoTo 0
ActiveWorkbook.Sheets("BDD").Range("A2:AS2").Copy .Range("A" & ligne) 'Position A dans le classeur destination.
Nomclasseur = ActiveWorkbook.Name
.Range("A" & .UsedRange.Rows.Count) = Left(Nomclasseur, InStr(1, Nomclasseur, ".xlsm") - 1)
End With
'Application.DisplayAlerts = False
ActiveWorkbook.Close False 'Nomfichier.Close
ligne = 0
' ****************** Fin de votre macro **********************************
' Fin si
End If
' fichier suivant
Next
' Fin si
End If
' S'il n'y a pas de sous-dossiers dans Nomdossier
If Nomdossiers Is Nothing Then
' Rien
Else
' Pour chaque dossier de la liste de dossiers
For Each Nomdossier In Nomdossiers
' Créer un objet de gestion des fichiers
Set Fso = CreateObject("Scripting.FileSystemObject")
' Affecte la liste des fichiers du dossier en cours
Set Nomfichiers = Fso.GetFolder(Nomdossier.Path).Files
' Appel la procédure d'ouverture des fichiers (récursif)
Call Ouvrir_fichier(Nomdossier.SubFolders, Nomfichiers)
' Dossier suivant
Next Nomdossier
' Fin si
End If
End Sub
Avant de pouvoir utiliser le code, allez dans l'éditeur VBA --> Outils --> references. Là vous devez activer l'option "Microsoft Scripting Runtime"
Cordialement
Fonctionne parfaitement
Merci pour ta patience