collage un à un !!!

glaine · 13 Octobre 2010

Bonjour à tous,
Comme d'habitude, merci d'avance pour toutes aides apportées. J'ai crée une macro qui cherche certaines valeurs dans une colonne et va les coller dans une autre :

Code:

Sub CollerExam()
Dim nbrecell As Integer
Dim plage As Range
Set plage = Range("A2", [A2].End(xlDown))
Cells.NumberFormat = "@"
For Each cell In plage.Cells
   If IsEmpty(Selection) = False Then
       If Not cell.Value Like "0*" Then
       Selection.Cut
       Range("C2").Select
       Selection.Insert Shift:=xlDown
       End If
   End If
Next
End Sub

Mon soucis est qu'elle prend toutes les valeurs de la colonne et les colle à l'endroit souhaité et finit par m'afficher un message d'erreur comme quoi la zone de coupe et de collage ne correspondent pas. J'ai essayé avec une boucle for + compteur sans plus de résultats. Merci d'avance à ceux qui pourraient m'éclairer.

Efgé · 13 Octobre 2010

Re : collage un à un !!!

Bonjour glaine,
Une proposition:

Code:

[COLOR=blue]Sub[/COLOR] CollerExam()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]Dim[/COLOR] plage [COLOR=blue]As[/COLOR] Range
[COLOR=blue]Set[/COLOR] plage = Range("A2", [A2].End(xlDown))
Cells.NumberFormat = "@"
[COLOR=blue]For Each[/COLOR] C [COLOR=blue]In[/COLOR] plage
   [COLOR=blue]If Not[/COLOR] IsEmpty(C) [COLOR=blue]And Not[/COLOR] C.Value [COLOR=blue]Like[/COLOR] "0*" [COLOR=blue]Then[/COLOR]
       Range("C2").Insert Shift:=xlDown
       Range("C2").Value = C.Value
       C.ClearContents
    [COLOR=blue]End If[/COLOR]
[COLOR=blue]Next[/COLOR]
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]

Cordialement

tototiti2008 · 13 Octobre 2010

Re : collage un à un !!!

Bonjour glaine, Bonjour Efgé,

Il n'y aurais pas de cellules fusionnées, d'un côté ou de l'autre ?

glaine · 13 Octobre 2010

Re : collage un à un !!!

Merci pour vos réponses, il n' y a pas de cellules fusionnées. La réponse EFgé semble correspondre, mais le résultat est surprenant, les valeurs collées apparaissent dans un ordre qui ne correspond pas à celui de départ. Il est inversé. Je vais essayé Range("C2").Value = C.Value-1
Merci encore

Efgé · 13 Octobre 2010

Re : collage un à un !!!

Re glaine, Bonjour tototiti2008 ,

glaine, si votre macro avait tournée, elle aurai également inversée les données...
Une double proposition (possibilité de laissé les valeurs de la colonne A en place ou de les regrouper) qui met les valeurs en C dans l'ordre d'origine:

Code:

[COLOR=blue]Sub[/COLOR] CollerExam2()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]Dim[/COLOR] L [COLOR=blue]As Long[/COLOR], i [COLOR=blue]As Long[/COLOR]
L = Cells(Rows.Count, "A").End(xlUp).Row
Cells.NumberFormat = "@"[COLOR=green] ' Pas utile[/COLOR]
[COLOR=blue]For[/COLOR] i = L [COLOR=blue]To[/COLOR] 2 [COLOR=blue]Step[/COLOR] -1
   [COLOR=blue]If[/COLOR] Trim(Cells(i, 1).Value) <> "" [COLOR=blue]And Not[/COLOR] Cells(i, 1).Value [COLOR=blue]Like[/COLOR] "0*" [COLOR=blue]Then[/COLOR]
       Range("C2").Insert Shift:=xlDown
       Range("C2").Value = Cells(i, 1).Value
       Cells(i, 1).ClearContents[COLOR=green] '*[/COLOR]
[COLOR=green]      '*Si vous voulez retrouver les valeurs en A regroupées:[/COLOR]
[COLOR=green]      'Cells(i, 1).Delete[/COLOR]
    [COLOR=blue]End If[/COLOR]
[COLOR=blue]Next[/COLOR] i
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]

Cordialement

glaine · 13 Octobre 2010

Re : collage un à un !!!

Merci à vous deux, il n'y a pas de cellules fusionnées. La solution d'EFgé fonctionne, mais donne un résultat inverse de celui attendu. La première valeur collée devrait être la dernière. Merci encore

Efgé · 13 Octobre 2010

Re : collage un à un !!!

Nous nous sommes croisés, regardez mon dernier post.
Cordialement

glaine · 13 Octobre 2010

Re : collage un à un !!!

Simplement merci, au vue de l'excellence de ta réponse, je mesure le chemin qui me reste à parcourir. Je retrousse mes manches. Problème résolu.
Cordialement

collage un à un !!!

glaine

XLDnaute Junior

Efgé

XLDnaute Barbatruc

tototiti2008

XLDnaute Barbatruc

glaine

XLDnaute Junior

Efgé

XLDnaute Barbatruc

glaine

XLDnaute Junior

Efgé

XLDnaute Barbatruc

glaine

XLDnaute Junior

Discussions similaires