copier un tableau via VBA (données et couleur de fond)

[gosselien]

Bonjour,

mon très faible niveau VBA ne me permet pas de solutionner ceci:

une feuille avec pour l'exemple des prénoms et une couleur de fond par prénom;
on me demande de faire une copie de ce tableau en dessous en ne gardant qu'une fois chaque prénom et en gardant aussi la couleur qui lui est attribuée et à côté le nombre de fois que chacun se trouve dans le tableau.

le copie se fait vers une colonne -prioritairement- ou une ligne, ça dépendra du nombre final de données que nous auront à l'import et d'un autre fichier assez proche.

Je préfère ceci en vba au TCD ne serait-ce que pour la couleur de fond mais aussi parce que le code pourra alors être adapté à une autre demande d'où le choix horizontal ou vertical (et d'autres critères que je vous épargne)

Merci

 

[phlaurent55]

Re : copier un tableau via VBA (données et couleur de fond)

Bonjour gosselien,

voir fichier joint

à+
Philippe

 

[job75]

Re : copier un tableau via VBA (données et couleur de fond)

Bonjour gosselien, Philippe,

Testez cette macro sur le fichier du post #1 :

Sub ListeEnCouleur()
Dim P As Range, dest As Range, restitution As Byte, t, ncol%
Dim d As Object, dcoul As Object, i&, j%
Set P = [D5:M8] 'à adapter
Set dest = [B18] 'à adapter
restitution = 0 '0 en colonne, 1 en ligne
t = P 'matrice, plus rapide
ncol = UBound(t, 2)
Set d = CreateObject("Scripting.Dictionary")
Set dcoul = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Rows(dest.Row & ":" & Rows.Count).Clear 'RAZ
For i = 1 To UBound(t)
  For j = 1 To ncol
    If t(i, j) <> "" Then
      If Not d.exists(t(i, j)) Then dcoul(t(i, j)) = P(i, j).Interior.Color
      d(t(i, j)) = d(t(i, j)) + 1
    End If
  Next
Next
If d.Count = 0 Then Exit Sub
'---restitution des prénoms et des nombres avec tri alphabétique---
If restitution Then
  dest.Resize(, d.Count) = d.keys
  dest(2).Resize(, d.Count) = d.items
  dest.Resize(2, d.Count).Sort dest, xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
Else
  dest.Resize(d.Count) = Application.Transpose(d.keys)
  dest(, 2).Resize(d.Count) = Application.Transpose(d.items)
  dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo, Orientation:=xlTopToBottom
End If
'---restitution des couleurs---
For Each dest In IIf(restitution, dest.Resize(, d.Count), dest.Resize(d.Count))
  dest.Interior.Color = dcoul(dest.Value)
Next
End Sub

Il y a restitution des prénoms, des nombres (d'apparition) et des couleurs.

Le paramètre restitution permet de choisir l'orientation.

A+

 

[gosselien]

Re : copier un tableau via VBA (données et couleur de fond)

re,

super !!!

merci à vous 2, je vais regarder de plus près à ce code vba , car dans les tableaux je suis ..dans la panade

Patrick


Edit: ça fonctionne comme prévu, un grand merci

A mon tour d'aider.... quand je peux, donc à un autre niveau