XL 2016 copie de donnees horizontale en verticale

[richardlion]

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]

Bonjour richardlion, le forum,

Il suffit de traiter tous les tableaux :

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]

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

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]

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]

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]

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

Bonjour richardlion, le forum,

Il suffit de traiter tous les tableaux :

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 richardlion, le forum,

Il suffit de traiter tous les tableaux :

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]

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]

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 :

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]

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 :

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