VBA code qui fonctionne mal copié collé valeur tableau

Bonjour,

J'ai un tableau source que j'ai tous les mois avec des données différentes et je voudrais créer un historique.
J'ai un autre tableau cible dans le quel j'ai préparé le même tableau et ainsi avec une macro je peut copié collé en valeur mes données.

Jai travaillé sur une macro qui je pense peut être amélioré enfin elle fonctionne mais j'ai un problème quand je la lance, les données se colle mais commence à la ligne 2 du tableau cible et pas à la 1ère et ce que je vdourais aussi c'est que cela soit dans le tableau

Je met les deux fichier Excel ainsi que le code en dessous

Sub CopierTableaux()

    Dim wbSource As Workbook
    Dim wbCible As Workbook
    Dim wsSource As Worksheet
    Dim wsCible As Worksheet
    Dim tbl As ListObject
    Dim rngSource As Range
    Dim lastRow As Long
    Dim nomTableau As String

    ' Désactiver l'actualisation de l'écran
    Application.ScreenUpdating = False

    ' Spécifiez ici le chemin du fichier cible
    Dim cheminFichierCible As String
    cheminFichierCible = "C:\Users\etc"

    ' Ouvrir le fichier source (le fichier actuel)
    Set wbSource = ThisWorkbook

    ' Ouvrir le fichier cible
    Set wbCible = Workbooks.Open(cheminFichierCible)

    ' Parcourir chaque feuille de calcul dans le fichier source
    For Each wsSource In wbSource.Worksheets
        ' Parcourir chaque tableau dans la feuille de calcul
        For Each tbl In wsSource.ListObjects
            nomTableau = tbl.Name

            ' Définir la plage à copier (sans la première et la dernière ligne)
            If tbl.ListRows.Count > 2 Then ' Assurez-vous qu'il y a plus de 2 lignes
                Set rngSource = tbl.DataBodyRange.Offset(1, 0).Resize(tbl.ListRows.Count - 2)

                ' Ouvrir la feuille de calcul cible correspondante
                On Error Resume Next
                Set wsCible = wbCible.Worksheets(wsSource.Name)
                On Error GoTo 0

                If Not wsCible Is Nothing Then
                    ' Trouver la première ligne vide à partir de la première ligne
                    lastRow = wsCible.Cells(wsCible.Rows.Count, 1).End(xlUp).Row

                    ' Si lastRow est supérieur à 0, on doit coller à la ligne suivante
                    If lastRow > 0 Then
                        lastRow = lastRow + 1
                    End If

                    ' Coller les données en tant que valeurs dans la feuille cible
                    rngSource.Copy
                    wsCible.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False ' Pour désactiver le mode de copie

                    ' Aligner le texte : centrer horizontalement et aligner à gauche verticalement
                    With wsCible.Range(wsCible.Cells(lastRow, 1), wsCible.Cells(lastRow + rngSource.Rows.Count - 1, rngSource.Columns.Count))
                        .HorizontalAlignment = xlCenter ' Centrer horizontalement
                        .VerticalAlignment = xlCenter ' Centrer verticalement
                    End With
                End If
            End If
        Next tbl
    Next wsSource

    ' Fermer le fichier cible
    wbCible.Close SaveChanges:=True

    ' Libérer les objets
    Set wbSource = Nothing
    Set wbCible = Nothing
    Set wsSource = Nothing
    Set wsCible = Nothing
    Set tbl = Nothing
    Set rngSource = Nothing

    MsgBox "Les tableaux ont été copiés avec succès en tant que valeurs et formatés !"

End Sub

j'ai déjà testé et cela à l'air de fonctionner a part les problèmes ci dessus
Si j'ai un deuxiême et un troisème tableau etc cela se colle bien l'un en dessous de l'autre.

Merci pour votre aide et n'hésitez pas si il y a des interrogations ?

Bonjour,

Les lignes que vous copiez ne s'ajoutent pas dans le tableau structuré.

A tester :

Option Explicit

Sub Test()

Dim Continuer As Boolean
Dim I As Integer, J As Integer
Dim TblSource As ListObject, TblCible As ListObject
Dim LigneCible As ListRow
Dim RngSource As Range
Dim NomTableau As String, CheminFichierCible As String
Dim WbSource As Workbook, WbCible As Workbook
Dim WsSource As Worksheet, WsCible As Worksheet

    Application.ScreenUpdating = False                      ' Désactiver l'actualisation de l'écran

    CheminFichierCible = ThisWorkbook.Path & "\cible.xlsx"  ' Spécifiez ici le chemin du fichier cible
    Set WbSource = ThisWorkbook                             ' Ouvrir le fichier source (le fichier actuel)
    Set WbCible = Workbooks.Open(CheminFichierCible)        ' Ouvrir le fichier cible
    Continuer = False

    For Each WsSource In WbSource.Worksheets                ' Parcourir chaque feuille de calcul dans le fichier source

        For Each TblSource In WsSource.ListObjects          ' Parcourir chaque tableau dans la feuille de calcul

            If Not TblSource.DataBodyRange Is Nothing Then
               NomTableau = TblSource.Name
               Set RngSource = TblSource.DataBodyRange      ' Définir la plage à copier (sans la première et la dernière ligne)
               For J = 1 To WbCible.Sheets.Count
                   If WbCible.Sheets(J).Name = NomTableau Then
                      Set WsCible = WbCible.Sheets(J)
                      Continuer = True
                      Exit For
                   End If
               Next J
            End If

            If Continuer = False Then GoTo Fin

            For I = 1 To RngSource.Rows.Count
                Set LigneCible = WsCible.ListObjects(1).ListRows.Add
                RngSource.Rows(I).Copy
                LigneCible.Range(1, 1).PasteSpecial Paste:=xlPasteValues
                Set LigneCible = Nothing
            Next I

            Set WsCible = Nothing

        Next TblSource

     Next WsSource

     WbCible.Close savechanges:=True

     GoTo Fin

Fin:

    Set WbSource = Nothing: Set WbCible = Nothing:  Set WsCible = Nothing

    Application.ScreenUpdating = True

End Sub

Bonjour,

Merci mais cela ne fonctionne pas non plus
J'ai essayer plusieurs version et rien j'ai toujours la ligne 2 vide dans mon tableau structuré cible
Je ne comprend pas, aprés je peut laisser ainsi mais c'est bof

Cordialement,

Mes fichiers

Bonjour,

Merci cela fonctionne j'avais oublié quelque chose en collant merci pour ton aide c'est good

Cordialement,