Boucle sur une plage déterminée par la cellule active et copie sur un autre onglet

**yanou91** · 16/02/2016, 15h52

Bonjour,

Je sollicite votre aide sur une difficulté au niveau du codage VBA. Je vais joindre le fichier et le code mais j'explique ce que je tente de réaliser. J'ai un tableau (onglet "revue contrat") où sont répertorier des types d'essai. Je souhaiterais, qu'une boucle parcours la colonne nommé A2 (K) jusqu'à A17 (AA) afin de trouver si la valeur "x" existe. Tout cela, dans la ligne indiquée par la cellule active.

Ensuite, si la boucle trouve l'élément "x", je souhaite copier le nom du type d'essai, autrement dit, copier la valeur de la ligne numéro 2.

Je souhaite que le nom du type d'essai soit copié sur l'onglet "étiquette" dans la plage B8 à D8. Sachant que trois "x" maximum peuvent être repérés et donc trois types d'essai recopiés.

Je souhaite également que si la colonne AB (onglet "revue contrat") n'est pas vide, que la valeur soit recopié sur la cellule B9 de l'onglet étiquette.

Pourriez vous m'aider sur le code déjà réalisé svp.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
 
Sub étiquette()
'
'
' Récupération de la ligne sélectionnée
    iligne = ActiveCell.Row
    J = ActiveCell.Column
 
' Identification des colonnes importantes
 
    itypeessai = 11
    itypeessai2 = 27
    itypeessai3 = 28
 
    Dim myRange As Range
    Dim cell As Range
    Set myRange = Range(Cells(iligne, itypeessai), Cells(iligne, itypeessai2))
 
       For Each cell In myRange
    If cell.Value = "x" Then
 
Sheets("étiquette").Range("D8:D8").ClearContents
Sheets("étiquette").Range("B9").ClearContents
cell.End(xlUp).Offset(1, 0).Copy Sheets("étiquette").Range("A8").End(xlToRight).Offset(1, 0).Paste
 
End If
 
Next
 
Dim myRange2 As Range
 
    Set myRange2 = Cells(iligne, itypeessai3)
 
If myRange2.Value <> "" Then
myRange2.Value.Copy Sheets("étiquette").Range("B9").Paste
End If    
 
 
End Sub

En vous remerciant

**goldstar** · 16/02/2016, 16h30

Bonjour,

Un truc du genre:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
 
 
Sub étiquette()
 
Dim cpt_c As Integer, colonneCibleVide As Integer
 
'
'
' Récupération de la ligne sélectionnée
    iligne = ActiveCell.Row
    J = ActiveCell.Column
 
' Identification des colonnes importantes
    iclient = 1             ' CLIENT en colonne A
    inumdossier = 29        ' numéro du dossier en colonne AC
    itypeclassement = 31    ' type de classement en colonne AE
    iautreprest = 28        ' autre prestation en colonne AB
    icommande = 30          ' commande en colonne AD
    idevis = 32             ' commande en colonne AF
    ificheinfo = 33         ' fiche info en colonne AG
    iechantillon = 34       ' echantillon en colonne AH
    idatearrivage = 35      ' date d'arrivage en colonne AI
    ivieillissement = 36    ' vieillissement en colonne AJ
    ietatdossier = 37       ' etat du dossier en colonne AK
    idateverif = 38         ' date vérification en colonne AL
    iverificateur = 39      ' vérificateur en colonne AM
    itypeessai = 11
    itypeessai2 = 27
    itypeessai3 = 28
 
    Dim myRange As Range
    Dim cell As Range
    Set myRange = Range(Cells(iligne, itypeessai), Cells(iligne, itypeessai2))
 
    colonneCibleVide = 1
 
    For cpt_c = itypeessai To itypeessai2
        If Sheets("revue contrat").Cells(iligne, cpt_c) = "x" Then
            colonneCibleVide = colonneCibleVide + 1
 
            Sheets("étiquette").Cells(colonneCibleVide, 8) = Sheets("revue contrat").Cells(2, cpt_c)
 
        End If
    Next cpt_c
 
    If Sheets("revue contrat").Cells(iligne, 28) <> "" Then
        Sheets("étiquette").Range("B9") = Sheets("revue contrat").Cells(iligne, 28).Value
    End If
 
'    For Each cell In myRange
'        If cell.Value = "x" Then
'            colonneCibleVide = colonneCibleVide + 1
'
'
'
'Sheets("étiquette").Range("D8:D8").ClearContents
'Sheets("étiquette").Range("B9").ClearContents
'cell.End(xlUp).Offset(1, 0).Copy Sheets("étiquette").Range("A8").End(xlToRight).Offset(1, 0).Paste
'
'    End If
'
'Next
 
'If Range("iligne:itypeessai3").Value <> "" Then
'Range("iligne:itypeessai3").Value.Copy Sheets("étiquette").Range("B9").Paste
'End If
 
 
 
 
End Sub

Cordialement,

**yanou91** · 16/02/2016, 18h51

Envoyé par goldstar

Bonjour,

Un truc du genre:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
 
 
Sub étiquette()
 
Dim cpt_c As Integer, colonneCibleVide As Integer
 
'
'
' Récupération de la ligne sélectionnée
    iligne = ActiveCell.Row
    J = ActiveCell.Column
 
' Identification des colonnes importantes
    iclient = 1             ' CLIENT en colonne A
    inumdossier = 29        ' numéro du dossier en colonne AC
    itypeclassement = 31    ' type de classement en colonne AE
    iautreprest = 28        ' autre prestation en colonne AB
    icommande = 30          ' commande en colonne AD
    idevis = 32             ' commande en colonne AF
    ificheinfo = 33         ' fiche info en colonne AG
    iechantillon = 34       ' echantillon en colonne AH
    idatearrivage = 35      ' date d'arrivage en colonne AI
    ivieillissement = 36    ' vieillissement en colonne AJ
    ietatdossier = 37       ' etat du dossier en colonne AK
    idateverif = 38         ' date vérification en colonne AL
    iverificateur = 39      ' vérificateur en colonne AM
    itypeessai = 11
    itypeessai2 = 27
    itypeessai3 = 28
 
    Dim myRange As Range
    Dim cell As Range
    Set myRange = Range(Cells(iligne, itypeessai), Cells(iligne, itypeessai2))
 
    colonneCibleVide = 1
 
    For cpt_c = itypeessai To itypeessai2
        If Sheets("revue contrat").Cells(iligne, cpt_c) = "x" Then
            colonneCibleVide = colonneCibleVide + 1
 
            Sheets("étiquette").Cells(colonneCibleVide, 8) = Sheets("revue contrat").Cells(2, cpt_c)
 
        End If
    Next cpt_c
 
    If Sheets("revue contrat").Cells(iligne, 28) <> "" Then
        Sheets("étiquette").Range("B9") = Sheets("revue contrat").Cells(iligne, 28).Value
    End If
 
'    For Each cell In myRange
'        If cell.Value = "x" Then
'            colonneCibleVide = colonneCibleVide + 1
'
'
'
'Sheets("étiquette").Range("D8:D8").ClearContents
'Sheets("étiquette").Range("B9").ClearContents
'cell.End(xlUp).Offset(1, 0).Copy Sheets("étiquette").Range("A8").End(xlToRight).Offset(1, 0).Paste
'
'    End If
'
'Next
 
'If Range("iligne:itypeessai3").Value <> "" Then
'Range("iligne:itypeessai3").Value.Copy Sheets("étiquette").Range("B9").Paste
'End If
 
 
 
 
End Sub

Cordialement,

Merci Goldstar. ta macro fonctionne tres bien, notamment sur la partie "autre prestation" à utiliser.

Cordialement.

**Menhir** · 16/02/2016, 17h34

Je n'ai pas regardé ton code mais voilà ce que je te propose :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Etiquette()
   Dim L_Source As Long
   Dim C_Source As Integer
   Dim Cpt As Integer
 
   Cpt = 0
   L_Source = ActiveCell.Row
   For C_Source = 10 To 27
       If Cells(L_Source, C_Source) = "x" Then
           Worksheets("étiquette").Cells(8, 2 + Cpt).Value = Cells(2, C_Source)
           Cpt = Cpt + 1
           If Cpt = 3 Then Exit For
       End If
   Next C_Source
End Sub

**yanou91** · 16/02/2016, 18h21

Merci Goldstar pour ta réponse. La copie des types d'essai ne se produit pas au bon endroit dans l'onglet etiquette et la copie se fait en vertical plutôt qu'en horizontale sur la plage B8 à D8 .S'agissant du type "Autre", cela fonctionne bien s'il y a un élément, mais si c'est vide la macro rapporte le mot "autre" dans l'onglet étiquette là où elle ne devrait rien remonter dans ce cas.

Merci d'avoir essayé et d'avoir pris du temps pour aider. J'essaie également de voir ce que je peux faire en modifiant un peu ton code, sans succes pour le moment.

Merci Menhir d'avoir répondu. Cela doit être à cause de mon manque de maitrise mais je n'arrive pas à actionner ta macro. VBA me dit que la macro doit ne pas être disponible pour le classeur "etiquette"; J'avoue ne pas comprendre pourquoi il n'exécute pas la macro afin que je vois le résultat.

CDT.

yannick

**Menhir** · 16/02/2016, 18h31

Envoyé par yanou91

Cela doit être à cause de mon manque de maitrise mais je n'arrive pas à actionner ta macro. VBA me dit que la macro doit ne pas être disponible pour le classeur "etiquette"; J'avoue ne pas comprendre pourquoi il n'exécute pas la macro afin que je vois le résultat.

Peut-être parce que j'ai changé le "é" du nom de la macro en "E".
Si tu lances ta macro à partir d'un bouton, il faut refaire la liaison du bouton vers la macro.

Attention, j'avais fait une faute de frappe dans le Next final. Ce n'est pas un 8 mais un _ qu'il faut mettre après C.

**yanou91** · 16/02/2016, 18h48

Envoyé par Menhir

Peut-être parce que j'ai changé le "é" du nom de la macro en "E".
Si tu lances ta macro à partir d'un bouton, il faut refaire la liaison du bouton vers la macro.

Attention, j'avais fait une faute de frappe dans le Next final. Ce n'est pas un 8 mais un _ qu'il faut mettre après C.

Merci beaucoup Menhir. J'avais vu le 8 à la place du _ mais pas le nom de la Macro ... ce qui est pourtant la base, je serai plus attentif la prochaine fois.

Cordialement.

**Marc-L** · 16/02/2016, 18h40

Bonjour, Bonjour !

Envoyé par yanou91

Je souhaiterais, qu'une boucle parcours la colonne nommé A2 (K) jusqu'à A17 (AA) afin de trouver si la valeur "x" existe. Tout cela, dans la ligne indiquée par la cellule active.

Ensuite, si la boucle trouve l'élément "x", je souhaite copier le nom du type d'essai, autrement dit, copier la valeur de la ligne numéro 2.

Pourquoi une boucle ? Il n'y en a pas besoin ! …

______________________________________________________________________________________________________
Je suis Paris, Charlie, …

**yanou91** · 16/02/2016, 18h53

Envoyé par Marc-L

Bonjour, Bonjour !

Pourquoi une boucle ? Il n'y en a pas besoin ! …

______________________________________________________________________________________________________
Je suis Paris, Charlie, …

C'est ce que je vois en voyant les posts des contributeurs, mon raisonnement était mauvais.

Yannick

**Marc-L** · 16/02/2016, 19h18

T'as pas dû bien encore digérer leurs codes car ils utilisent une boucle !

Démonstration sans boucle :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub Demo()
    R& = ActiveCell.Row
    If R < 3 Or R > Cells(1).CurrentRegion.Rows.Count Then Beep: Exit Sub
    VA = Filter(Evaluate("IF(K" & R & ":AA" & R & ">"""",K2:AA2)"), False, False)
    With Feuil3.[B8]
        .Resize(, 3).ClearContents
        If UBound(VA) >= 0 Then .Resize(, Application.Min(UBound(VA) + 1, 3)).Value = VA
        .Offset(1).Value = Cells(R, "AB").Value
    End With
End Sub

______________________________________________________________________________________________________

Merci de cliquer sur

pour chaque message ayant aidé puis sur

pour clore cette discussion …

**yanou91** · 16/02/2016, 19h43

Je pensais que le If tout seul n'était plus une boucle ... j'ai pas mal d'abus de langage (my mistake).

En tout cas ta solution fonctionne également parfaitement.

Merci beaucoup.

Yannick