Importer que les nouvelles lignes d'un fichier A vers un fichier B

Le 16/05/2022 à 11:02

Bonjour à tous,

Je vous sollicite aujourd'hui pour une nouvelle question.

J'ai un code qui me permet d'importer toutes les données de mon fichier d'origine à chaque fois que j'actionne la macro. Je vous la colle en dessous. Ce code ne me convient plus pour diverses raisons, je ne veux plus effacer tout le contenu de mon tableau de destination et voudrais seulement importer les lignes qui ont été rajoutées dans mon fichier source MAIS je voudrais que ces lignes rajoutées dans mon fichier de destination ne soit pas coller à la suite mais avant les autres.

Pour ça, j'ai pensé à deux options :

- Rajouter une nouvelle boucle qui regarderait les lignes similaires puis ne copierait que les lignes qui n'ont pas de match dans le fichier de destination

ou

- compter le nb de lignes sur fichier de destination, le stocker dans une variable et dans fichier source, importer les lignes dont le num est superieur à cette variable...

Je sais pas trop ce qui est le mieux. j'ai essayé différentes modifications mais aucune n'a fonctionné. Quelqu'un peut-il m'aider?

Je vous remercie d'avance !

16fichier-de-destination.xlsm (27.50 Ko)
14classeur-source.xlsx (15.27 Ko)
Sub CODETEST()
Dim CD As Workbook
Dim OD As Worksheet
Dim EF As FileDialog
Dim CS As Workbook
Dim OS As Worksheet
Dim TV As Variant
Dim TL() As Variant
Dim I As Integer
Dim K As Integer
Dim LastRowSource As Long
Dim RowDestination As Integer
Application.ScreenUpdating = False
Set CD = ThisWorkbook

'' Set OD = CD.Worksheets(1) (définit OD dans les deux boucles lorsqu'une correspondance est trouvée)
''' OD.Range("B1").CurrentRegion.Offset(1, 0).ClearContents (ajouter en dessous)

Set EF = Application.FileDialog(msoFileDialogOpen)
EF.AllowMultiSelect = False
EF.Show
If EF.SelectedItems.Count = 0 Then Exit Sub
'Set CS = Workbooks.Open(EF.SelectedItems(1))
Set CS = GetObject(EF.SelectedItems(1))
''' Set OS = CS.Worksheets(1) 'définit l'onglet source OS (définit l'OS dans les deux boucles lorsque la correspondance est trouvée)

Dim wsCD As Worksheet, wsCS As Worksheet

''' boucle sur toutes les feuilles de CD
For Each wsCD In CD.Worksheets

    ''' boucle sur toutes les feuilles dans CS
    For Each wsCS In CS.Worksheets

        ''' si vous trouvez des feuilles avec des noms correspondants, faites les recopies
        If wsCD.Name = wsCS.Name Then

            Set OD = wsCD ''' c'est-à-dire que ce sera CD.Worksheets(wsCD.Name)
            OD.Range("B2").CurrentRegion.Offset(1, 0).ClearContents

            Set OS = wsCS ''' c'est-à-dire que ce sera OS.Worksheets(wsCS.Name)

            ''' faire les actions en dessous
            RowDestination = 2
            TV = OS.Range("B7").CurrentRegion 'définit le tableau des valeurs TV
            LastRowSource = OS.Range("B" & Rows.Count).End(xlUp).row

            With OS.Range("B8:F" & LastRowSource)
                .AutoFilter field:=1, Criteria1:="OK"

            End With

            For Each cl In OS.Range("C8:F" & LastRowSource).SpecialCells(xlCellTypeVisible).EntireRow 'Boucle sur les lignes qui reste visible après le filtre
                OD.Cells(RowDestination, 2) = "OK"
                OD.Cells(RowDestination, 3) = cl.Cells(3)
                OD.Cells(RowDestination, 4) = cl.Cells(4)
                OD.Cells(RowDestination, 5) = cl.Cells(5)
                OD.Cells(RowDestination, 6) = cl.Cells(6)
                RowDestination = RowDestination + 1
            Next cl

            If K > 0 Then OD.Range("B2").Resize(K, 3) = Application.Transpose(TL)

        End If

    Next wsCS

Next wsCD

''' done, close CS
CS.Close SaveChanges:=False
Application.ScreenUpdating = True

MsgBox "Import terminé !", vbInformation

    Set OD = Nothing: Set OS = Nothing
    Set CD = Nothing
    Set fd = Nothing

End Sub
Le 16/05/2022 à 15:00

Bonjour,

ci-jointe une proposition en utilisant la classe associée à vos tableaux structurés :

Sub CODETEST()
    Dim CD As Workbook, CS As Workbook
    Dim wsCD As Worksheet
    Dim EF As FileDialog
    Dim I As Integer
    Dim import_proj As ListObject, dest_proj As ListObject
    Dim ligne As ListRow
    Dim dic_import_proj As Object, dic_dest_proj As Object
    Dim code As Variant, remontée As String

    Application.ScreenUpdating = False
    Set CD = ThisWorkbook

    '' Set OD = CD.Worksheets(1) (définit OD dans les deux boucles lorsqu'une correspondance est trouvée)
    ''' OD.Range("B1").CurrentRegion.Offset(1, 0).ClearContents (ajouter en dessous)

    Set EF = Application.FileDialog(msoFileDialogOpen)
    EF.AllowMultiSelect = False
    EF.Show
    If EF.SelectedItems.Count = 0 Then Exit Sub
    'Set CS = Workbooks.Open(EF.SelectedItems(1))
    Set CS = GetObject(EF.SelectedItems(1))
    ''' Set OS = CS.Worksheets(1) 'définit l'onglet source OS (définit l'OS dans les deux boucles lorsque la correspondance est trouvée)

    ''' boucle sur toutes les feuilles de CD
    For Each wsCD In CD.Worksheets

        '// création d'un dictionnaire des codes de destination
        Set dic_dest_proj = CreateObject("Scripting.Dictionary") 'création dictionnaire destination du projet
        Set dest_projet = wsCD.ListObjects(1)                    'assignation tableau structuré de la feuille destination
        With dest_projet
            For I = 1 To .ListRows.Count
                code = .ListColumns("Code").DataBodyRange(I)
                dic_dest_proj(code) = code
            Next I
        End With

        '// création d'un dictionnaire des importations de projet dont le code n'existe pas dans le projet de destination
        Set dic_import_proj = CreateObject("Scripting.Dictionary") 'création dictionnaire importation du projet
        Set import_projet = CS.Sheets(wsCD.Name).ListObjects(1)    'assignation tableau structuré de la feuille importation du projet de destination
        With import_projet
            For I = 1 To .ListRows.Count
                code = .ListColumns("Code").DataBodyRange(I)
                remontée = .ListColumns("Remontées N+1?").DataBodyRange(I)
                If Not dic_dest_proj.exists(code) And remontée = "OK" Then
                    dic_import_proj(code) = .DataBodyRange.Rows(I).Value
                End If
            Next I
        End With

        '// insertion dans le projet de destination des lignes dont le code n'existe pas
        For Each clé In dic_import_proj
            With dest_projet
                Set ligne = .ListRows.Add(1)                                            'insertion à la première ligne du tableau structuré
                .ListRows(2).Range.Copy: .ListRows(1).Range.PasteSpecial xlPasteFormats 'recopie format ancienne première ligne
                ligne.Range.Value = dic_import_proj(clé)                                'valeur ligne à partir de celle stockée dans le dictionnaire
            End With
        Next clé
        Application.CutCopyMode = False

    Next wsCD

    ''' done, close CS
    CS.Close SaveChanges:=False
    Application.ScreenUpdating = True

    MsgBox "Import terminé !", vbInformation

    Set CD = Nothing

End Sub
Le 17/05/2022 à 09:27

Bonjour @thev,

Je vous remercie pour votre proposition.

Etant encore novice au langage, je n'ai pas tcompris comment vous avez défini le tableau initial et le tableau de destination. Pouriez-vous m'éclairer sur ce point s'il vous plaît ?

Lucas

Le 17/05/2022 à 14:20

Bonjour le fil,

Au lieu d'utiliser un dictionnaire, pouvons nous utiliser une collection? Dans mon vrai fichier, il n'y a pas de code/clé....

Cordialement,

Lucas

Le 17/05/2022 à 20:20

Bonjour,

Etant encore novice au langage, je n'ai pas tcompris comment vous avez défini le tableau initial et le tableau de destination. Pouriez-vous m'éclairer sur ce point s'il vous plaît ?

Vos projets sont sous la forme de tableaux structurés. Si vous cliquez sur l'un des éléments, vous verrez apparaitre en haut à droite un menu qui lui est propre intitulé "Outils de tableau" dans votre version d'Excel. Au tableau structuré est associé une classe spécifique : ListObject avec la collection ListObjects toujours liée à une feuille. Le tableau structuré de la feuille destination et celui de la feuille importation qui lui est lié sont donc définis par ces instructions :

Set dest_projet = wsCD.ListObjects(1) qui représente le premier tableau structuré de la feuille wsCD du classeur de destination et le seul car il n'y en a pas d'autre

Set import_projet = CS.Sheets(wsCD.Name).ListObjects(1) qui représente le premier tableau structuré de la feuille du classeur d'importation portant le même nom que celui de la feuille du classeur de destination

Enfin, pour terminer un petit mémo sur l'utilisation d'un tableau structuré en VBA

Un tableau structuré Excel est en fait l’équivalent d’une table Access.

  • Il est borné car le nombre de ses lignes et colonnes est obligatoirement défini
  • Il est identifié par son nom et les entêtes de ses colonnes.

Utilisation de la classe ListObject

Ses principales propriétés sont les objets :

  • Range = ensemble du tableau
  • HeaderRowRange = ligne des entêtes de colonne
  • DataBodyRange = lignes des données du tableau
  • TotalsRowRange = ligne des totaux du tableau si elle a été définie
  • ListRows = lignes du tableau
  • ListColumns = colonnes du tableau

Assignation du tableau structuré à partir de son nom :

Dim tb_struct As ListObject

Dim feuille As Worksheet

Set tb_struct = Range("nom_du_tableau").ListObject

'feuille où se trouve le tableau

Set feuille = tb_struct.Range.Worksheet

Gestion des lignes du tableau :

Dim ligne As ListRow

Dim i As Integer, nb_lig As Integer, nb_col As Integer

'// nombre de lignes

nb_lig = tb_struct.ListRows.Count

'// nombre de colonnes

nb_col = tb_struct.ListColumns.Count

'// ajout d'une ligne et indice de la ligne ajoutée

Set ligne = tb_struct.ListRows.Add: i = ligne.Index

'// suppression d'une ligne d'indice i

tb_struct.ListRows(i).Delete

'// vidage intégral du tableau

tb_struct.DataBodyRange.Delete

'// modification d'une ligne d'indice i

tb_struct.ListColumns("entête_de_la colonne").DataBodyRange(i) = valeur

'// recherche de l'indice d'une ligne du tableau à partir d'une valeur de recherche

Dim cell As Range

Set cell = tb_struct.Range.Find(valeur_recherchée)

'indice de la ligne du tableau

i = cell.Row - tb_struct.HeaderRowRange.Row

Le 17/05/2022 à 20:31
Au lieu d'utiliser un dictionnaire, pouvons nous utiliser une collection? Dans mon vrai fichier, il n'y a pas de code/clé...
Dans votre fichier, vous devez avoir un élément qui identifie de manière unique votre ligne. j'ai supposé que c'était le code. C'est le seul moyen de reconnaître les nouvelles lignes apportées par le classeur importation. Si ce n'est pas le cas, il faut alors revenir à un système de suppression/remplacement.

Par ailleurs, la collection a moins de propriétés et de méthodes que le dictionnaire. Par exemple, pour vérifier l'existence d'une clé, le dictionnaire possède la propriété .exists. Pour une collection, une boucle sera nécessaire pour le déterminer.
Le 18/05/2022 à 13:24

Merci beaucoup Thev, je prend note de tout cela!

Merci encore :-)

Lucas

Le 31/05/2022 à 10:25

Bonjour le fil, je reviens de nouveau après avoir modifié mon code afin qu'il colle avec mon vrai fichier. Le soucis c'est que je n'ai pas compris comment a fait @thev pour le collage special. je n'y arrive pas...

Quelqu'un pourrait-il m'aider ?

Sub CODE()
    Dim CD As Workbook, CS As Workbook
    Dim wsCD As Worksheet
    Dim EF As FileDialog
    Dim I As Integer
    Dim import_proj As ListObject, dest_proj As ListObject
    Dim ligne As ListRow
    Dim dic_import_proj As Object, dic_dest_proj As Object

    Application.ScreenUpdating = False
    Set CD = ThisWorkbook

    Set EF = Application.FileDialog(msoFileDialogOpen)
    EF.AllowMultiSelect = False
    EF.Show
    If EF.SelectedItems.Count = 0 Then Exit Sub
    'Set CS = Workbooks.Open(EF.SelectedItems(1))
    Set CS = GetObject(EF.SelectedItems(1))
    ''' Set OS = CS.Worksheets(1) 'définit l'onglet source OS (définit l'OS dans les deux boucles lorsque la correspondance est trouvée)

    ''' boucle sur toutes les feuilles de CD
    For Each wsCD In CD.Worksheets
            Dim SearchSheet As Boolean
            SearchSheet = False
            For Each wsCS In CS.Worksheets
                If wsCD.Name = wsCS.Name Then
                    SearchSheet = True
                End If
            Next wsCS

         If SearchSheet = True Then
          '// création d'un dictionnaire des codes de destination
            Set dic_dest_proj = CreateObject("Scripting.Dictionary") 'création dictionnaire destination du projet

                For I = 58 To wsCD.Range("C" & Rows.Count).End(xlUp).Row
                    Dim error As Boolean
                     error = False
                        Dim newLine As New AnomalyClass
                        If IsNumeric(wsCD.Cells(I, 3)) = True And wsCD.Cells(I, 3) > 0 Then
                           newLine.Id = wsCD.Cells(I, 3)
                         Else
                            error = True
                    End If
                    newLine.NumLine = I
                    newLine.RootCause = wsCD.Cells(I, 4)
                    newLine.Resp = wsCD.Cells(I, 5)
                    newLine.Origine = wsCD.Cells(I, 7)
                    newLine.SMP = wsCD.Cells(I, 9)
                    newLine.Statut = wsCD.Cells(I, 10)
                    If IsNumeric(wsCD.Cells(I, 11)) = True And wsCD.Cells(I, 11) > 0 Then
                            newLine.Heure = wsCD.Cells(I, 11)
                    Else
                         error = True
                    End If

                    newLine.Description = wsCD.Cells(I, 12)
                    If error = False Then
                        dic_dest_proj.Add newLine.Id, newLine
                    End If
                Next I
            'End With

            '// création d'un dictionnaire des importations de projet dont le code n'existe pas dans le projet de destination
            Set dic_import_proj = CreateObject("Scripting.Dictionary") 'création dictionnaire importation du projet

                For J = 32 To CS.Sheets(wsCD.Name).Range("C" & Rows.Count).End(xlUp).Row
                    'code = .ListColumns("Code").DataBodyRange(I)
                    Dim error2 As Boolean
                    Dim remonter As String
                    error2 = False

                    Dim code As Integer

                    If IsNumeric(CS.Sheets(wsCD.Name).Cells(J, 2)) = True And CS.Sheets(wsCD.Name).Cells(J, 2) > 0 Then
                           code = CS.Sheets(wsCD.Name).Cells(J, 2)
                         Else
                            error2 = True
                    End If
                    If Not IsNumeric(CS.Sheets(wsCD.Name).Cells(J, 11)) = True And CS.Sheets(wsCD.Name).Cells(J, 11) > 0 Then
                        error2 = True
                    End If
                    remonter = CS.Sheets(wsCD.Name).Cells(J, 3)
                    If dic_dest_proj.exists(code) = False And error2 = False Then

                      Dim newLine2 As New AnomalyClass
                        newLine2.Id = code
                        newLine2.NumLine = J
                        newLine2.RootCause = CS.Sheets(wsCD.Name).Cells(J, 4)
                        newLine2.Resp = CS.Sheets(wsCD.Name).Cells(J, 5)
                        newLine2.Origine = CS.Sheets(wsCD.Name).Cells(J, 7)
                        newLine2.SMP = CS.Sheets(wsCD.Name).Cells(J, 9)
                        newLine2.Statut = CS.Sheets(wsCD.Name).Cells(J, 10)
                        newLine2.Heure = CS.Sheets(wsCD.Name).Cells(J, 11)
                        dic_import_proj.Add code, newLine2
                    End If
                Next J

            'On doit copier le contenu de dic_import_proj dans le fichier
            If dic_import_proj.Count > 0 Then

            For Each clé In dic_import_proj
                For J = 32 To CS.Sheets(wsCD.Name).Range("C" & Rows.Count)
                    Set ligne = CS.Sheets(wsCD.Name).Range("C" & Rows.Count).Add(1)         'insertion à la première ligne du tableau structuré
                    .ListRows(2).Range.Copy: .ListRows(1).Range.PasteSpecial xlPasteFormats 'recopie format ancienne première ligne
                    ligne.Range.Value = dic_import_proj(clé)                                'valeur ligne à partir de celle stockée dans le dictionnaire
                Next I
            Next clé
             '// insertion dans le projet de destination des lignes dont le code n'existe pas

            Application.CutCopyMode = False
            End If
         End If

    Next wsCD

    ''' done, close CS
    CS.Close SaveChanges:=False
    Application.ScreenUpdating = True

    MsgBox "Import terminé !", vbInformation

    Set CD = Nothing

End Sub

En effet, mon code à partir de cet endroit est faux car je n'arrive pas à faire comme @thev a fait...

'On doit copier le contenu de dic_import_proj dans le fichier
If dic_import_proj.Count > 0 Then

            For Each clé In dic_import_proj
                For J = 32 To CS.Sheets(wsCD.Name).Range("C" & Rows.Count)
                    Set ligne = CS.Sheets(wsCD.Name).Range("C" & Rows.Count).Add(1)         'insertion à la première ligne du tableau structuré
                    .ListRows(2).Range.Copy: .ListRows(1).Range.PasteSpecial xlPasteFormats 'recopie format ancienne première ligne
                    ligne.Range.Value = dic_import_proj(clé)                                'valeur ligne à partir de celle stockée dans le dictionnaire
                Next I
            Next clé

Je vous remercie d'avance

Lucas

Rechercher des sujets similaires à "importer que nouvelles lignes fichier"