Boucle de copie valeur

[Pipaobzh]

Bonjour,
Je souhaite creer une boucle pour simplifié mon code mais je bloque.


Code original :
If Sheets("Perception").Range("E5") > 0 Then
Sheets("Suivi").Range("A" & Lig) = Sheets("Perception").Range("C3") 'N°Perception
Sheets("Suivi").Range("B" & Lig) = Sheets("Perception").Range("C1") 'Nom Instance
Sheets("Suivi").Range("C" & Lig) = Sheets("Perception").Range("C2") 'Date
Sheets("Suivi").Range("D" & Lig) = Sheets("Perception").Range("A5") 'ID
Sheets("Suivi").Range("E" & Lig) = Sheets("Perception").Range("B5") 'RA
Sheets("Suivi").Range("F" & Lig) = Sheets("Perception").Range("C5") 'DESIGNATION
Sheets("Suivi").Range("G" & Lig) = Sheets("Perception").Range("E5") 'QT
Sheets("Suivi").Range("H" & Lig) = Environ("UserName") 'Utilisateur
Sheets("Suivi").Range("I" & Lig) = "PERCEPTION(SORTIE)" 'Type
Lig = Lig + 1
End If


If Sheets("Perception").Range("E6") > 0 Then
Sheets("Suivi").Range("A" & Lig) = Sheets("Perception").Range("C3") 'N°Perception
Sheets("Suivi").Range("B" & Lig) = Sheets("Perception").Range("C1") 'Nom Instance
Sheets("Suivi").Range("C" & Lig) = Sheets("Perception").Range("C2") 'Date
Sheets("Suivi").Range("D" & Lig) = Sheets("Perception").Range("A6") 'ID
Sheets("Suivi").Range("E" & Lig) = Sheets("Perception").Range("B6") 'RA
Sheets("Suivi").Range("F" & Lig) = Sheets("Perception").Range("C6") 'DESIGNATION
Sheets("Suivi").Range("G" & Lig) = Sheets("Perception").Range("E6") 'QT
Sheets("Suivi").Range("H" & Lig) = Environ("UserName") 'Utilisateur
Sheets("Suivi").Range("I" & Lig) = "PERCEPTION(SORTIE)" 'Type
Lig = Lig + 1
End If

Etc.... sur une centaine de lignes. J ai pensé a :

Dim x As Long
x = 5
Do While Sheets("Perception").Range("E" & x) > 0

Sheets("Suivi").Range("A" & Lig) = Sheets("Perception").Range("C3") 'N°Perception

Sheets("Suivi").Range("B" & Lig) = Sheets("Perception").Range("C1") 'Nom Instance

Sheets("Suivi").Range("C" & Lig) = Sheets("Perception").Range("C2") 'Date

Sheets("Suivi").Range("D" & Lig) = Sheets("Perception").Range("A" & x) 'ID

Sheets("Suivi").Range("E" & Lig) = Sheets("Perception").Range("B" & x) 'RA

Sheets("Suivi").Range("F" & Lig) = Sheets("Perception").Range("C" & x) 'DESIGNATION

Sheets("Suivi").Range("G" & Lig) = Sheets("Perception").Range("E" & x) 'QT

Sheets("Suivi").Range("H" & Lig) = Environ("UserName") 'Utilisateur

Sheets("Suivi").Range("I" & Lig) = "PERCEPTION(SORTIE)" 'Type
x = x + 1
Lig = Lig + 1
Loop

Le soucis est que si la premiere cellule E5 est vide cela ne copie pas les valeur des autres cellules remplie E6 E7 etc...

Quelqu un voit il d'ou vient le probleme ?

Merci

 

[Paf]

Bonjour et bienvenue sur XLD,

Le problème vient du fait que vous demandez de faire une boucle tant que Ex est >0; dès qu'on rencontre une cellule E.. =0, on sort de la boucle !

Peut-être modifier en utilisant, par exemple,une boucle For ... Next :

lig = zz 'à initialiser
For i = 5 To Range("E" & Rows.Count).End(xlUp).Row ' de 5 à dernière ligne
    If Sheets("Perception").Range("E" & x) > 0 Then
        Sheets("Suivi").Range("A" & lig) = Sheets("Perception").Range("C3") 'N°Perception
        Sheets("Suivi").Range("B" & lig) = Sheets("Perception").Range("C1") 'Nom Instance
        Sheets("Suivi").Range("C" & lig) = Sheets("Perception").Range("C2") 'Date
        Sheets("Suivi").Range("D" & lig) = Sheets("Perception").Range("A" & i) 'ID
        Sheets("Suivi").Range("E" & lig) = Sheets("Perception").Range("B" & i) 'RA
        Sheets("Suivi").Range("F" & lig) = Sheets("Perception").Range("C" & i) 'DESIGNATION
        Sheets("Suivi").Range("G" & lig) = Sheets("Perception").Range("E" & i) 'QT
        Sheets("Suivi").Range("H" & lig) = Environ("UserName") 'Utilisateur
        Sheets("Suivi").Range("I" & lig) = "PERCEPTION(SORTIE)" 'Type
        lig = lig + 1
    End If
Next

A+

 

[JBARBE]

Bonjour à tous,

Peut-être ceci en tenant compte que lig = 1 ( à modifier s'il a lieu)
La sortie de la boucle est ainsi : If .Range("E" & i) = "" Then Exit Sub > si ("E "& i)= vide alors sortie

Attention à PERCEPTION(SORTIE)

Option Explicit

Sub test()
Dim lig As Long
Dim x As Long
Dim i As Long
Application.ScreenUpdating = False
With Sheets("Perception")
lig = 1
x = 5
For i = lig To 65000
If .Range("E" & i) = "" Then Exit Sub
If .Range("E" & i) > 0 Then
.Range("C3").Copy  Sheets("Suivi").Range("A" & lig)
.Range("C1").Copy  Sheets("Suivi").Range("B" & lig)
.Range("C2").Copy  Sheets("Suivi").Range("C" & lig)
.Range("A" & x).Copy  Sheets("Suivi").Range("D" & lig)
.Range("B" & x).Copy  Sheets("Suivi").Range("E" & lig)
.Range("C" & x).Copy  Sheets("Suivi").Range("F" & lig)
.Range("E" & x).Copy  Sheets("Suivi").Range("G" & lig)
Environ("UserName").Copy  Sheets("Suivi").Range("H" & lig)
PERCEPTION(SORTIE).Copy  Sheets("Suivi").Range("I" & lig)
x = x + 1
lig = lig + 1
Exit For
Else
x = x + 1
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

bonne journée !

 

[Pipaobzh]

Fonctionne très bien.
Merci beaucoup
Si jamais d autres personnes veulent se servir du code, pensez a definir le i en variable : dim i as long.

 

[Pipaobzh]

Mon lig est la pour prendre la premiere ligne vide disponible

Dim lig as Long
Lig=3
Do while not isempty(range("A" & Lig))
Lig=Lig+1
Loop

 

[Paf]

Re et bonjour JBARBE

Fonctionne très bien.
Merci beaucoup

de quelle proposition parlez vous ?

Dans la mienne il faudrait apporter cette modification:
For i = 5 To Sheets("Perception").Range("E" & Rows.Count).End(xlUp).Row

par ailleurs pour initialiser Lig, on pourrait utiliser:

Lig = Sheets("Suivi").Range("A" & Rows.Count).End(xlUp).Row+1

A+

 

[Pipaobzh]

Je parle de votre solution paf. Etant debutant en vba je n'avais pas compris que je sortais de la boucle en cas de faux avec le loop. Mais plus de soucis avec le for next. Encore merci

 

[Yurperqod]

Bonjour le forum

Une autre macro simplifiée avec une écriture que j'ai pu parfois lire sur ce forum

Sub Macro1()
Dim WS_A As Worksheet, WS_B As Worksheet
Dim lig As Long, i As Long
Set WS_A = Sheets("Suivi")
Set WS_B = Sheets("Perception")
lig = WS_A.Range("A" & Rows.Count).End(xlUp).Row + 1
For i = 5 To WS_B.Range("E" & Rows.Count).End(xlUp).Row ' de 5 à dernière ligne
If WS_B.Range("E" & i) > 0 Then
WS_A.Cells(lig, 1).Resize(, 3) = Array(WS_B.[C3], WS_B.[C1], WS_B.[C2])
WS_A.Cells(lig, 4).Resize(, 4) = Array(WS_B.Cells(i, "A"), WS_B.Cells(i, "B"), WS_B.Cells(i, "C"), WS_B.Cells(i, "E"))
WS_A.Cells(lig, 8).Resize(, 2) = Array(Environ("UserName"), "PERCEPTION(SORTIE)")
lig = lig + 1
End If
Next
End Sub

macro testée sans classeur d'exemple, donc pas certain du résultat de ces lignes VBA.

 

[JBARBE]

Re,
Je ne me sens pas offensé si ma proposition n'est pas retenue !
D'ailleurs il aurait été préférable comme toujours dans ce forum de joindre un fichier !
Et puis, j'habite au bord de la mer et avec ce soleil, je serais ridicule de rester planté derrière mon ordi !
Bonne journée !