Fusionner plusieurs classeurs avec condition

Le 27/07/2016 à 14:59

Bonjour,

J'ai un soucis pour fusionner plusieurs fichiers dans un fichier qui se nomme recap.xlms

Il faut que mon fichier recap.xlms fusionne toutes les feuilles 1 de chaque fichier qui sont dans le repertoire "tdb-tech".

Jusque là, j'avais réussi (j'effaçais les colonnes et je recopiais toutes les lignes contenant dans les tableaux) mais je souhaite maintenant faire différemment.

Je ne dois plus effacer le tableau mais alimenter le tableau avec des conditions.

Je dois donc ajouter les conditions suivantes :

Si l'id qui se trouve en colonne A est déjà présent dans la tableau récap, je remplace la ligne qui contient cette valeur
Si l'id est nouveau, je copie/colle la ligne à la fin du tableau du fichier recap.xlms.

Mon code de fusion est le suivant et fonctionne bien

    Sub Regroupe()
        Dim maitre As Workbook, nf, chemin$, n&
        chemin = ThisWorkbook.Path & "\tdb-tech\"
        Set maitre = ActiveWorkbook
        ActiveSheet.[A2].CurrentRegion.Offset(1, 0).Clear
        nf = Dir(chemin & "*.xlsm")
        With maitre.Sheets(1)
            Do While nf <> ""
                n = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                Workbooks.Open chemin & nf
                [A1].CurrentRegion.Offset(1, 0).Copy
                .Cells(n, 1).PasteSpecial xlPasteValues
                .Cells(n, 1).PasteSpecial xlPasteFormats

                ActiveWorkbook.Close False
                nf = Dir
            Loop
        End With
    End Sub

J'ai souhaité ajouter les conditions et c'est là où je coince. c'est un code que j'ai trouvé sur le forum et que j'ai essayé d'adapter.

Sub Regroupe()
        Dim maitre As Workbook, nf, chemin$, n&
        Dim WsS As Worksheet, WsC As Worksheet
        Dim Cel As Range, C As Range
        Dim LigneAjout As Long

        Application.ScreenUpdating = False

        chemin = ThisWorkbook.Path & "\tdb-tech\"
        'on définit ici le dossier où se trouve les fichiers par rapport au fichier qui consolide

        Set maitre = ActiveWorkbook
        Set WsS = Worksheets("Feuil1")
        Set WsC = Worksheets("fusion")
        'ActiveSheet.[A2].CurrentRegion.Offset(1, 0).Clear
        nf = Dir(chemin & "*.xlsm")
        'on définit l'extension des fichiers

        With maitre.Sheets(1)
            Do While nf <> ""
                'Je boucle tant que j'ai un fichier xlsm dans le répertoire
                Workbooks.Open chemin & nf

                ' J'ouvre chaque fichier
                For Each Cel In WsS.Range("A2:A" & WsS.Range("A" & Rows.Count).End(xlUp).Row)
                'On cherche une correspondance de chaque clé dans chaque fichier du répertoire
                Set C = WsS.Columns(1).Find(Cel, , xlValues, xlWhole)
                LigneAjout = WsC.Range("A" & Rows.Count).End(xlUp).Row + 1
                'Si la valeur existe déjà dans la colonne A
                If Not C Is Nothing Then
                'alors, on effectue la copie des données de la colonne A à la colonne P de la feuille "Fusion"
                Cel.Resize(, 16).Copy
              'puis on effectue le remplacement de ces données dans la feuille "Fusion"
                WsC.Range("A" & C.Row).PasteSpecial (xlPasteValues)
                WsC.Range("A" & C.Row).PasteSpecial (xlPasteFormats)
                Else
                'sinon, on effectue la copie des données de la colonne A à la colonne P de la feuille ""
                 Cel.Resize(, 16).Copy
                 'puis on effectue le collage de ces données dans une nouvelle ligne de la feuille "Rapport"
                 WsC.Range("A" & LigneAjout).PasteSpecial (xlPasteValues)
                 WsC.Range("A" & LigneAjout).PasteSpecial (xlPasteFormats)
                LigneAjout = LigneAjout + 1
            End If
             Next Cel
             Application.CutCopyMode = False
            Set C = Nothing: Set WsS = Nothing: Set WsC = Nothing

            ActiveWorkbook.Close False
             nf = Dir
            Loop
        End With
    End Sub

Je pense qu'il y a plusieurs soucis mais le principal est que je ne sais pas comment aller appliquer les conditions dans chaque fichier qui est dans le dossier tdb-tech.

Je vous remercie par avance pour votre aide.

26tdb-tech.zip (46.79 Ko)

Le 28/07/2016 à 11:31

Bonjour

voici un essai.

fred

Option Explicit
Sub recupere()
Dim WsS, WsD As Object

Dim Fso As Object
Dim SourceFolder As Object
Dim FileItem As Object
Dim chemin As String
Dim adresse As Range
Dim i, LR As Integer

chemin = ThisWorkbook.Path & "\tdb-tech\"
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(chemin)
Set WsD = ThisWorkbook.Sheets(1)
'Boucle sur tous les fichiers du répertoire
For Each FileItem In SourceFolder.Files
        If Right(FileItem.Name, 4) = "xlsm" Then
            Workbooks.Open (chemin & FileItem.Name)
            Set WsS = ActiveWorkbook.Sheets(1)
            For i = 2 To WsS.Cells(Rows.Count, "A").End(xlUp).Row 'passe en revu toute les lignes du fichier ouvert(source)

                'on copie les données
                WsS.Range(Cells(i, "A"), Cells(i, "U")).Copy
                'vérification si une entrée existe déjà
                'Si non => ligne de destination = fin du tableau + 1 ligne
                'si oui => ligne de destination = l'entrée précédente
                Set adresse = WsD.[A:A].Find(What:=WsS.Cells(i, "A"), LookAt:=xlPart)                
                If adresse Is Nothing Then 'valeur non trouvée
                    LR = WsD.Cells(Rows.Count, "A").End(xlUp).Row + 1
                Else: LR = adresse.Row 'valeur trouvée
                End If
                'collage des données dans le fichier de destination avec le format des cellules
                WsD.Cells(LR, "A").PasteSpecial xlPasteValues
                WsD.Cells(LR, "A").PasteSpecial xlPasteFormats
            Next i
            'fermeture du fichier sans enrefistrement
            ActiveWorkbook.Close False
        End If

Next FileItem 'passe au ficheir suivant
End Sub

Le 28/07/2016 à 14:35

Merci Beaucoup !!

C'est exactement ce que je voulais.

Le 04/08/2016 à 14:52

Bonjour Fred,

J'ai finalement un soucis sur le script, si la valeur existe déjà, il passe la ligne.

En fait je souhaite que la ligne soit remplacée si la valeur existe déjà.

Peux tu me dire ce que je dois modifier?

Je pense que c'est sur la ligne Else: LR = adresse.Row 'valeur trouvée

Lionel

Le 04/08/2016 à 17:00

Bonjour