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"

3bdd-crf.xlsm (25.41 Ko)

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 Dan,

Désolé pour ma réponse tardive.

J'ai ce message :

capture

Sur la ligne suivante :

NomClasseur = Dir("C:\Users\SLE\Downloads\CRF2021\*.xlsm")

Il y a bien des fichiers (.xslm) dans ce dossier. J'ai aussi testé en ouvrant ces deux fichiers, mais meme message

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

Rechercher des sujets similaires à "copie ligne bdd"