Microsoft 365 Macro copier/coller entre deux tableaux structurés

NONO14 · Samedi à 17:50

Bonjour à toutes et à tous,
Dans une feuille de calcul j'ai un premier TS qui est nommé t_Recap et qui est la source des données.
Dans une deuxième feuille j'ai un deuxième TS qui est nommé t_Import et qui est la destination.

t_Import comporte moins de colonnes que t_Recap, ils ont en communs les colonnes suivantes :

t_Recap (A) = t_Import (A) - Code agent
t_Recap (B) = t_Import (B) - NOM Prénom
t_Recap (C) = t_Import (C) - Date
t_Recap (J) = t_Import (D) - Total heures matin
t_Recap (K) = t_Import (E) - Total heures après-midi
t_Recap (L) = t_Import (F) - Total heures soir
t_Recap (M) = t_Import (G) - Total heures jour
t_Recap (N) = t_Import (H) - Total heures Sup
t_Recap (O) = t_Import (I) - Nbre de plages
t_Recap (P) = t_Import (J) - Commentaires

J'ai fait la macro suivante avec l'enregistreur de macros mais elle ne fonctionne que pour la ligne 2.
Ce que je souhaite mettre en place avec votre aide, c'est une macro qui me copie à partit du TS source et colle les données dans le TS destination à partir de la ligne 2 et jusqu'à la fin du TS et seulement les colonnes définies ci-dessus.
Pourriez-vous m'aider à mettre ça en place s'il vous plaît ?
Je vous en remercie par avance

Ensuite, je mettrai en place un code pour imprimer le TS t_Import.

VB:

Sub CopierColler()
'
' CopierColler Macro
   
    Range("A2:C2,J2:P2").Select
    Range("t_Recap[TOTAL Heures matin]").Activate
    Selection.Copy
    Sheets("Imp_Pointage").Select
    Range("t_Import[Code agent]").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

job75 · Dimanche à 15:23

job75 à dit:
Cette macro est très simple :

VB:

Sub CopierColler() If Not [t_Import].ListObject.DataBodyRange Is Nothing Then [t_Import].Delete Intersect([t_Recap], [t_Recap].Parent.Range("A:C,J:P")).Copy [t_Import].Cells(1) End Sub

On constate que les formules sont remplacées par leurs valeurs.

Et alors ?

NONO14 · Hier à 13:31

NONO14 à dit:
D'accord. Je vais le tester alors.

Effectivement il fait le travail. Je dois cependant ajouter une MsgBox pour demander la confirmation du transfert. Là je devrais pouvoir me débrouiller.
Encore merci pour le code

TooFatBoy · Hier à 13:42

job75 à dit:
Bah si tu testes la macro du post #40, comme je l'ai dit aucun problème si tu déplaces le tableau.

Décidément, tu y tiens à ton #40.
Je te promets que je le testerais aussi.

Merci encore pour ton aide.
Tschüss

NONO14 · Hier à 13:48

Une question sans doute idiote.
xlAscending veut bien dire du plus petit au plus grand ? et xlDescending l'inverse.
J'ai un trou de mémoire

NONO14 · Hier à 13:52

Voici le code avec mes petits ajouts. J'ai également changé l'ordre de tri en commençant par la date et ensuite le code agent.

VB:

Sub CopierColler()

If MsgBox("Etes-vous certain de vouloir transférer les pointages ?" & Chr(10) & "Attention les données seront effacées", vbYesNo, "Demande de confirmation") = vbYes Then

If Not [t_Import].ListObject.DataBodyRange Is Nothing Then [t_Import].Delete
    
    With [t_Recap]
    If Application.CountIf(.Rows(1), "><") + Application.Count(.Rows(1)) = 0 Then Exit Sub 'si aucune donnée à transférer
    Union(.Columns("A:C"), .Columns("J:P")).Copy [t_Import].Cells(1)
    .Delete
    End With

    With [t_Import]
    .ListObject.Range.Sort .Columns(3), xlAscending, , .Columns(1), xlAscending, Header:=xlYes 'tri sur 2 colonnes
    .Font.Size = 10
    .EntireColumn.AutoFit 'ajustement largeurs
    .Parent.Activate
    ActiveSheet.PageSetup.LeftHeader = "Semaine N° : " & Sheets("Calcul").Range("M3") & " " & " - " & "  " & "Du : " & "Lundi " & Sheets("Calcul").Range("M5") & "  " & "Au : " & "Dimanche " & Sheets("Calcul").Range("M6")
    ActiveSheet.PrintPreview
    End With

End Sub

Phil69970 · Hier à 13:57

Re

Et pour surement ma dernière intervention sur ce fil
A la date d'hier soir c'est à dire jusqu'au post #45
Il y a que 4 codes qui fonctionne 100% TS pour moi et qui répondent à la demande initiale.
==> Post # 8, 9, 12 et 40

Il est dommage que le demandeur n'est pas fait lui même ces tests pour se faire une idée.
Mais à t'il ouvert les autres posts et les a t'il essayé !!

Et j'avais écrits au post #33 exactement comme Chris l'a dit au post # 53 !

Bonne continuation

NONO14 · Hier à 14:43

Phil69970 à dit:
Re

Et pour surement ma dernière intervention sur ce fil
A la date d'hier soir c'est à dire jusqu'au post #45
Il y a que 4 codes qui fonctionne 100% TS pour moi et qui répondent à la demande initiale.
==> Post # 8, 9, 12 et 40

Il est dommage que le demandeur n'est pas fait lui même ces tests pour se faire une idée.
Mais à t'il ouvert les autres posts et les a t'il essayé !!

Et j'avais écrits au post #33 exactement comme Chris l'a dit au post # 53 !

Regarde la pièce jointe 1204293

Bonne continuation

J'ai testé les différentes propositions et ne voyant pas les subtilités que vous avez énoncées, j'en étais resté à mon code initial, code que j'ai changé à présent.
Je suis désolé si j'ai offusqué quelqu'un, ce n'est pas mon intention

job75 · Hier à 19:18

Pour terminer proprement ce fil.

Le If de la 2ème ligne de la macro du post #64 nécessite un End If en bas de la macro.

Ou bien plus simplement terminez cette ligne par un Exit Sub :

VB:

If MsgBox("Etes-vous certain de vouloir transférer les pointages ?" & Chr(10) & "Attention les données seront effacées", vbYesNo, "Demande de confirmation") = vbNo Then Exit Sub

Microsoft 365 Macro copier/coller entre deux tableaux structurés

NONO14

XLDnaute Occasionnel

job75

NONO14

XLDnaute Occasionnel

TooFatBoy

XLDnaute Barbatruc

NONO14

XLDnaute Occasionnel

NONO14

XLDnaute Occasionnel

Phil69970

XLDnaute Barbatruc

NONO14

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Discussions similaires