Copier selon couleur

[CelluleVide]

Bonjour,
La macro copie les cellules de la plage selectionnée a la suite de la liste en feuil "recap"
La couleur étant "en dur" dans la macro, Je voudrais pouvoir choisir cette couleur avec la palette Excel ou un Userform qui aurait les différentes couleurs de la plage choisie.

D'autre part, quand on prend une plage assez large, la macro rame un peu. je pense que la syntaxe de la phase "collage" est a revoir.

Merci.

 

[Efgé]

Re : Copier selon couleur

Bonjour CelluleVide,
Pour le UserForm je ne sais pas faire, pour la deuxième question (gagner du temps) je propose ceci:

[COLOR=blue]Sub[/COLOR] Copier_selon_couleur()
[COLOR=blue]Dim[/COLOR] Derlign [COLOR=blue]As Long[/COLOR], Cel [COLOR=blue]As[/COLOR] Range, Couleur  [COLOR=blue]As Integer[/COLOR]
[COLOR=blue]Dim[/COLOR] Tablo()
Couleur = 34
k = 0
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]ReDim[/COLOR] Tablo(k)
[COLOR=blue]For Each[/COLOR] Cel [COLOR=blue]In[/COLOR] Selection
    [COLOR=blue]If[/COLOR] Cel.Interior.ColorIndex = Couleur [COLOR=blue]Then[/COLOR]
        Tablo(k) = Cel.Value
        k = k + 1
        [COLOR=blue]ReDim Preserve[/COLOR] Tablo(k)
    [COLOR=blue]End If[/COLOR]
[COLOR=blue]Next[/COLOR] Cel
[COLOR=blue]If[/COLOR] k > 0 [COLOR=blue]Then[/COLOR]
    [COLOR=blue]With[/COLOR] Sheets("Recap")
        .Range("A" & .Range("A65536").End(xlUp).Offset(1, 0).Row).Resize([COLOR=blue]UBound[/COLOR](Tablo)) = Application.Transpose(Tablo)
    [COLOR=blue]End With[/COLOR]
[COLOR=blue]End If[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]

Cordialement

 

[CelluleVide]

Re : Copier selon couleur

Bonjour Efgé,

Effectivement ca gagne du temp en traitement.

Puis-je te demander des explications sur ton code pour essayer de me débrouiller seul la prochaine fois?

Merci pour ton aide.

 

[Efgé]

Re : Copier selon couleur

Re
Le code commenté:

[COLOR=blue]Sub[/COLOR] Copier_selon_couleur()
[COLOR=blue]Dim[/COLOR] Derlign [COLOR=blue]As Long[/COLOR], Cel [COLOR=blue]As[/COLOR] Range, Couleur  [COLOR=blue]As Integer[/COLOR]
[COLOR=green]'Declaration d'un tableau vide[/COLOR]
[COLOR=blue]Dim[/COLOR] Tablo()
Couleur = 34
[COLOR=green]'Initialisation de la variable k (un tableau commence à 0)[/COLOR]
k = 0
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=green]'Redimentionnement du tableau pour créer la valeur 0[/COLOR]
[COLOR=blue]ReDim[/COLOR] Tablo(k)
[COLOR=blue]For Each[/COLOR] Cel [COLOR=blue]In[/COLOR] Selection
   [COLOR=green]'Si la couleur interieure de la cellule est = à la couleur[/COLOR]
    [COLOR=blue]If[/COLOR] Cel.Interior.ColorIndex = Couleur [COLOR=blue]Then[/COLOR]
       [COLOR=green]'La valeur (k) du tableau est égale à la valeur de la cellule[/COLOR]
        Tablo(k) = Cel.Value
       [COLOR=green]'on incrémente la variable k[/COLOR]
        k = k + 1
       [COLOR=green]''On agrandi le tableau en conservant les valeurs déja entrées[/COLOR]
        [COLOR=blue]ReDim Preserve[/COLOR] Tablo(k)
    [COLOR=blue]End If[/COLOR]
[COLOR=blue]Next[/COLOR] Cel
[COLOR=green]'Si le tableau n'est pas vide[/COLOR]
[COLOR=blue]If[/COLOR] k > 0 [COLOR=blue]Then[/COLOR]
    [COLOR=blue]With[/COLOR] Sheets("Recap")
       [COLOR=green]'On colle le tableau en A et dernière ligne[/COLOR]
[COLOR=green]      'Comme on utilise un tableau à une seule dimention[/COLOR]
[COLOR=green]      '(une seule ligne et plusieurs colonnes)[/COLOR]
[COLOR=green]      'il faut utiliser Application Transpose[/COLOR]
        .Range("A" & .Range("A65536").End(xlUp).Offset(1, 0).Row).Resize([COLOR=blue]UBound[/COLOR](Tablo)) = Application.Transpose(Tablo)
    [COLOR=blue]End With[/COLOR]
[COLOR=blue]End If[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]

En espérant que c'est assez compréhensible...
Cordialement

 

[CelluleVide]

Re : Copier selon couleur

Encore Merci Efgé, je pense que j'arriverai a reproduire cela si besoin.

Il me reste a trouver comment reprendre cette satané couleur de cellule...

Cordialement.

 

[CelluleVide]

Re : Copier selon couleur

Ca y est!!! Fiat lux...

J'ai réussi a obtenir ce que je voulais:
La macro demande a l'utilisateur de choisir une couleur puis de selectionner la plage et copie les données en feuille recap.

Je poste le fichier résolu pour ceux que cela interesse...

Je n'aurais rien pu faire sans Efgé et les infos de ce forum magique

Merci aussi a Eric Renaud pour ces excellent didacticiels.

 

[Efgé]

Re : Copier selon couleur

Re
Si je puis me permettre:
En selectionnant, dans l'exemple, de A2 à F15 et en choisissant une cellule "blanche", le résultat n'est pas vraiment celui attendu.
Pour remédier à ce petit défaut on peut remplacer:

If Cel.Interior.ColorIndex = Couleur Then

Par

If Cel.Interior.ColorIndex = Couleur And Cel.Value <> "" Then

Cordialement

 

[CelluleVide]

Re : Copier selon couleur

Oups! je n'avais pas essayer le blanc

Ta suggestion est naturellement bienvenue.

A+