XL 2016 copie de donnees horizontale en verticale

richardlion · 10 Mars 2025

Bonjour a tous, je cherche une solution a mon probleme, en PJ vous trouverez un fichier avec 2 feuilles, une feuille synthèse et une feuille historique dans la feuille historique nous avons deux tableaux, un qui s'apelle TCD SECTEUR DEPOT et l'autre TCD FS DEPOT qui sont normalement Structurés car piloter par un segment de TCD.

quand je fais un filtre sur un seul depot pour ces deux tableaux je souhaite copier uniquement les valeurs des secteurs pour chaque tableau c'est a dire une ligne par tableau pour les copier en verticale dans la feuille SYNTHESE a la place des valeurs stabiloté en vert, l'ancrage de cette copie doit se faire par le nom des TCD SECTEUR DEPOT, TCDFS DEPOT et la date, je dois pouvoir actionner cette macro et aussi l'annuler. Dans la feuille historique il y a aura normalement plusieurs sauvegarde avec pour chaque double tableau une date en haut a gauche, la macro devra pouvoir copier les valeurs du filtre de plusieurs lignes de tableau dans la feuille synthese a partir de la colonne E et sur les futur colonnes suivantes qui se développeront de gauche vers la droite la copie des donnée sera toujours sur les meme lignes de la feuille synthese. a votre disposition pour échange

richardlion · Lundi à 19:46

job75 à dit:

Bonjour richardlion, le forum,

Il suffit de traiter tous les tableaux :

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LO As ListObject, c As Range
For Each LO In ListObjects
    LO.Range.Resize(LO.Range.Rows.Count + 1).Interior.ColorIndex = xlNone
Next LO
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
For Each LO In ListObjects
    Set c = LO.Range.Cells(Target.Row - ListObjects(1).Range.Row + 1, 1)
    c(1, 2).Resize(, 7).Interior.Color = vbYellow
Next LO
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
Dim LO As ListObject, c As Range, cc As Range
Cancel = True
For Each LO In ListObjects
    Set c = LO.Range.Cells(Target.Row - ListObjects(1).Range.Row + 1, 1)
    Set cc = Sheets("SYNTHESE").Columns(1).Find(LO.Range(1), , xlValues, xlWhole)
    If Not cc Is Nothing Then cc(2, 5).Resize(7) = Application.Transpose(c(1, 2).Resize(, 7))
Next LO
MsgBox "Feuille SYNTHESE mise à jour"
End Sub

Il faut bien sûr que chaque tableau ait sa correspondance dans la feuille SYNTHESE.

A+

Bonjour Job, ok je vais copier ta macro sur mon fichier d'origine pour voir comment ca focntionne je reviens vers toi pour te dire

richardlion · Lundi à 19:48

richardlion à dit:
Bonjour Job, ok je vais copier ta macro sur mon fichier d'origine pour voir comment ca focntionne je reviens vers toi pour te dire

richardlion à dit:
SYNTHESE-KPI-JOSS-BIS.xlsm

Le service des pièces jointes, CJoint.com est un service de partage de fichier gratuit pour partager vos documents dans vos courriels, sur les forums ou dans vos petites annonces.

www.cjoint.com

voici le lien tu as une feuille modop pour les explications si pas claire je suis la

j'ai oublié une chose importante, comment peut on avoir une macro qui me permet de revenir en arrière

job75 · Lundi à 20:07

richardlion à dit:
j'ai oublié une chose importante, comment peut on avoir une macro qui me permet de revenir en arrière

Là je pense que vous allez chercher midi à quatorze heure 🙄

richardlion · Lundi à 20:12

job75 à dit:
Là je pense que vous allez chercher midi à quatorze heure 🙄

oui je m'excuse mais quand j'affiche les infos je dois pouvoir revenir sur une situation globale et pas a la maille depot

richardlion · Lundi à 21:21

job75 à dit:
Là je pense que vous allez chercher midi à quatorze heure 🙄

job75 à dit:

Bonjour richardlion, le forum,

Il suffit de traiter tous les tableaux :

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LO As ListObject, c As Range
For Each LO In ListObjects
    LO.Range.Resize(LO.Range.Rows.Count + 1).Interior.ColorIndex = xlNone
Next LO
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
For Each LO In ListObjects
    Set c = LO.Range.Cells(Target.Row - ListObjects(1).Range.Row + 1, 1)
    c(1, 2).Resize(, 7).Interior.Color = vbYellow
Next LO
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
Dim LO As ListObject, c As Range, cc As Range
Cancel = True
For Each LO In ListObjects
    Set c = LO.Range.Cells(Target.Row - ListObjects(1).Range.Row + 1, 1)
    Set cc = Sheets("SYNTHESE").Columns(1).Find(LO.Range(1), , xlValues, xlWhole)
    If Not cc Is Nothing Then cc(2, 5).Resize(7) = Application.Transpose(c(1, 2).Resize(, 7))
Next LO
MsgBox "Feuille SYNTHESE mise à jour"
End Sub

Il faut bien sûr que chaque tableau ait sa correspondance dans la feuille SYNTHESE.

A+

job75 à dit:

Bonjour richardlion, le forum,

Il suffit de traiter tous les tableaux :

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LO As ListObject, c As Range
For Each LO In ListObjects
    LO.Range.Resize(LO.Range.Rows.Count + 1).Interior.ColorIndex = xlNone
Next LO
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
For Each LO In ListObjects
    Set c = LO.Range.Cells(Target.Row - ListObjects(1).Range.Row + 1, 1)
    c(1, 2).Resize(, 7).Interior.Color = vbYellow
Next LO
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
Dim LO As ListObject, c As Range, cc As Range
Cancel = True
For Each LO In ListObjects
    Set c = LO.Range.Cells(Target.Row - ListObjects(1).Range.Row + 1, 1)
    Set cc = Sheets("SYNTHESE").Columns(1).Find(LO.Range(1), , xlValues, xlWhole)
    If Not cc Is Nothing Then cc(2, 5).Resize(7) = Application.Transpose(c(1, 2).Resize(, 7))
Next LO
MsgBox "Feuille SYNTHESE mise à jour"
End Sub

Il faut bien sûr que chaque tableau ait sa correspondance dans la feuille SYNTHESE.

A+

Bonsoir Job, j'ai tester la macro est sur mes feuille ca ne fonctionne pas je vous met ci dessous un lien de mes deux feuille d'origne pour mieux comprendre https://www.cjoint.com/c/OCrutFVRZKe

job75 · Mardi à 00:05

J'ai téléchargé votre fichier, la macro SelectionChange va bien mais pour la 2ème macro :

1) dans la feuille HISTORISQUE TCD les 4 noms inscrits en 1ère cellule des tableaux doivent être différents, ce n'est pas le cas

2) ces 4 noms doivent se retrouver tels quels en 1ère colonne de la feuille SYNTHESE, ce n'est pas le cas.

job75 · Mardi à 07:08

Bonjour richardlion, le forum,

Plutôt que d'utiliser le fichier du post #20 (trop lourd) j'ai transféré ses données dans le fichier du post #13.

Et ajouté la variable col dans la 2ème macro :

VB:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
Dim LO As ListObject, c As Range, cc As Range, col%
Cancel = True
For Each LO In ListObjects
    Set c = LO.Range(Target.Row - ListObjects(1).Range.Row + 1, 1)
    Set cc = Sheets("SYNTHESE").Columns(1).Find(LO.Range(1), , xlValues, xlWhole)
    col = Application.Match(CLng(CDate(LO.Range(0, 1))), cc.EntireRow, 0) 'recherche la colonne de la date
    cc(2, col).Resize(8) = Application.Transpose(c(1, 2).Resize(, 8))
    cc(2).Resize(7).EntireRow.Interior.ColorIndex = xlNone 'RAZ
    cc(2, col).Resize(7).Interior.Color = vbYellow
Next LO
MsgBox "Feuille SYNTHESE mise à jour"
End Sub

Il faut bien sûr s'assurer que la date existe bien dans la feuille SYNTHESE.

Edit : dans la feuille SYNTHESE les 7 premières cellules de la plage traitée sont colorées en jaune.

A+

richardlion · Mardi à 19:06

job75 à dit:
Bonjour richardlion, le forum,

Plutôt que d'utiliser le fichier du post #20 (trop lourd) j'ai transféré ses données dans le fichier du post #13.

Et ajouté la variable col dans la 2ème macro :

VB:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub Dim LO As ListObject, c As Range, cc As Range, col% Cancel = True For Each LO In ListObjects Set c = LO.Range(Target.Row - ListObjects(1).Range.Row + 1, 1) Set cc = Sheets("SYNTHESE").Columns(1).Find(LO.Range(1), , xlValues, xlWhole) col = Application.Match(CLng(CDate(LO.Range(0, 1))), cc.EntireRow, 0) 'recherche la colonne de la date cc(2, col).Resize(8) = Application.Transpose(c(1, 2).Resize(, 8)) cc(2).Resize(7).EntireRow.Interior.ColorIndex = xlNone 'RAZ cc(2, col).Resize(7).Interior.Color = vbYellow Next LO MsgBox "Feuille SYNTHESE mise à jour" End Sub

Il faut bien sûr s'assurer que la date existe bien dans la feuille SYNTHESE.

Edit : dans la feuille SYNTHESE les 7 premières cellules de la plage traitée sont colorées en jaune.

A+

Bonjour j'ai un debogage sur la ligne en jaune, j'ai pourtant bien mes dates dans la feuille synthese et dans la feuille historique
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LO As ListObject, c As Range
For Each LO In ListObjects
LO.Range.Interior.ColorIndex = xlNone
Next LO
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
For Each LO In ListObjects
Set c = LO.Range.Cells(Target.Row - ListObjects(1).Range.Row + 1, 1)
c(1, 2).Resize(, 8).Interior.Color = vbYellow
Next LO
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Count > 1 Or Intersect(Target, Range(ListObjects(1).Name)) Is Nothing Then Exit Sub
Dim LO As ListObject, c As Range, cc As Range, col%
Cancel = True
For Each LO In ListObjects
Set c = LO.Range(Target.Row - ListObjects(1).Range.Row + 1, 1)
Set cc = Sheets("SYNTHESE").Columns(1).Find(LO.Range(1), , xlValues, xlWhole)
col = Application.Match(CLng(CDate(LO.Range(0, 1))), cc.EntireRow, 0) 'recherche la colonne de la date
cc(2, col).Resize(8) = Application.Transpose(c(1, 2).Resize(, 8))
cc(2).Resize(7).EntireRow.Interior.ColorIndex = xlNone 'RAZ
cc(2, col).Resize(7).Interior.Color = vbYellow
Next LO
MsgBox "Feuille SYNTHESE mise à jour"
End Sub

job75 · Mardi à 19:32

richardlion à dit:
Bonjour j'ai un debogage sur la ligne en jaune, j'ai pourtant bien mes dates dans la feuille synthese et dans la feuille historique

Vérifiez : la variable cc vaut Nothing si les 4 noms "TCD ZERO VENTES 1", "TCD FS 1", "TCD ZERO VENTES 2", "TCD FS 2" ne sont pas trouvés en colonne A de la feuille SYNTHESE. Attention aux espaces.

Ce qui est important c'est que mon fichier du post #22 fonctionne, après vous n'avez qu'à adapter le vôtre correctement.

richardlion · Mardi à 21:11

job75 à dit:
Vérifiez : la variable cc vaut Nothing si les 4 noms "TCD ZERO VENTES 1", "TCD FS 1", "TCD ZERO VENTES 2", "TCD FS 2" ne sont pas trouvés en colonne A de la feuille SYNTHESE. Attention aux espaces.

Ce qui est important c'est que mon fichier du post #22 fonctionne, après vous n'avez qu'à adapter le vôtre correctement.

en corrigeant les noms effectivement ca fonctionne, cela signifie que le 1 a sont importance? est il possible de fonctionner sans le 1 y a t'il une macro pour annuler la selection, merci a vous

job75 · Mardi à 22:02

richardlion à dit:
est il possible de fonctionner sans le 1

Allons allons, j'ai mis 1 et 2 pour qu'il n'y ait pas de doublon, mettez des noms sans doublon c'est tout.

XL 2016 copie de donnees horizontale en verticale

richardlion

XLDnaute Occasionnel

Pièces jointes

richardlion

XLDnaute Occasionnel

richardlion

XLDnaute Occasionnel

SYNTHESE-KPI-JOSS-BIS.xlsm

job75

XLDnaute Barbatruc

richardlion

XLDnaute Occasionnel

richardlion

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

richardlion

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

richardlion

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Discussions similaires

XL 2016 copie de donnees horizontale en verticale

XLDnaute Occasionnel

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency