Discussion :

[sylvain78]

Bonjour,

Je souhaite créer une macro qui copie/colle mes valeurs (pour effacer les formules) sur ma ligne active. Lorsqu'un X est indiqué en colonne AP alors la macro se déclenche pour copier/coller les valeurs de la colonne H à V, puis il rajoute une croix dans la colonne B + entrée.

Exemple

Quand j'ajoute un X sur la cellule E4, j'ai un copier/coller des cellules H4: V4 + un "X" qui s'indique dans la cellule B4 + entrée à la fin.

Avez vous une idée ?

Merci

[Menhir]

Lorsqu'un X est indiqué en colonne AP alors la macro se déclenche

Utilise l'évènement Worksheet_Change, en commençant par vérifier que la cellule modifiée appartient à la colonne AP.
https://msdn.microsoft.com/fr-fr/lib...5(v=office.15)

copier/coller les valeurs de la colonne H à V

Pour la copie : https://msdn.microsoft.com/fr-fr/lib...0(v=office.15)
Pour le collage de valeur, utilise PasteSpecial avec l'option xlPasteValues : https://msdn.microsoft.com/fr-fr/lib...6(v=office.15)

puis il rajoute une croix dans la colonne B + entrée.

Modifier la propriété Value de la cellule : https://msdn.microsoft.com/fr-fr/lib...3(v=office.15)

[sylvain78]

Merci de ta réponse ! Je débute en VBA est-ce que tu peux me corriger :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRgSel As Range
Set xRgSel = Range("AP1:AP200")
Set xRgSel = Intersect(Target, xRg)
With Worksheets("Sheet1") 
 .Range("H:V").Copy 
 .Range("H:V").PasteSpecial _ 
  Operation:=xlPasteValues
Worksheets("Sheet1").Range("A").Value = "X"
End With
End Sub

De plus cela sera sur des cellules protégé est-ce que cela pose problème ?

Merci

[Patrice740]

Je débute en VBA est-ce que tu peux me corriger

J'aurais écris :

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRgSel As Range, cel As Range, rng As Range
  Set xRgSel = Range("AP1:AP200")
  Set xRgSel = Intersect(Target, xRgSel)
  If xRgSel Is Nothing Then Exit Sub
  Me.Unprotect
  For Each cel In xRgSel.Cells
    If UCase(cel.Value) = "X" Then
      Set rng = Intersect(cel.EntireRow, Me.Columns("H:V"))
      rng.Value = rng.Value
      cel.EntireRow.Cells(1, "B").Value = "X"
  End If
  Next cel
  Me.Protect  'et éventuellement le mot de passe (inutile à mon avis)
End Sub

[sylvain78]

Merci Patrice,

Malheureusement ça ne marche pas pour la partie copier/coller valeurs.

J'ai essayé de modifier ton code, pour le copier/coller

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRgSel As Range, cel As Range, rng As Range
  Set xRgSel = Range("AP1:AP200")
  Set xRgSel = Intersect(Target, xRgSel)
  If xRgSel Is Nothing Then Exit Sub
  Me.Unprotect (1234)
  For Each cel In xRgSel.Cells
    If UCase(cel.Value) = "X" Then
Sheets("A").Range("C:H").Copy
Sheets("A").Range("C:H").PasteSpecial xlPasteValues
      rng.Value = rng.Value
      cel.EntireRow.Cells(1, "B").Value = "X"
  End If
  Next cel
  Me.Protect (1234) 'et éventuellement le mot de passe (inutile à mon avis)
End Sub

Or ça copie/colle sur la colonne C à H, mais je souhaite uniquement le faire sur la ligne correspondant à l'ajout du X

Je ne sais pas comment faire

[sylvain78]

Au final je viens de réessayer et ça marche ! Je ne sais pas pourquoi, j'ai du faire une fausse manip hier !

J'ai déjà un code VBA sur cette même feuille, comment faire pour mettre celle-ci à la suite ?

Voici mon 1er code VBA

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
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xRgSel As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xMailBody As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set xRg = Range("B4:B273")
    Set xRgSel = Intersect(Target, xRg)
    ActiveWorkbook.Save
    If Not xRgSel Is Nothing Then
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        xMailBody = "Bonjour à tous," & vbNewLine & vbNewLine & _
        "Un nouvel " & Cells(Target.Row, 25) & " à été ajouté " & Cells(Target.Row, 8) & " (" & Cells(Target.Row, 9) & ")" & " dans le fichier, en cellule " & xRgSel.Address(False, False) & _
            "' le " & _
            Format$(Now, "mm/dd/yyyy") & " à " & Format$(Now, "hh:mm") & _
            " par " & Environ$("username") & "." & vbNewLine & vbNewLine & _
            "Pour rappel le fichier est consultable à cette adresse : " & ThisWorkbook.FullName & vbNewLine & vbNewLine & _
            "Merci par avance pour votre validation express," & vbNewLine & vbNewLine & _
            ""
        With xMailItem
            .To = Cells(Target.Row, 14) & Cells(Target.Row, 18)
            .Cc = ""
            .Subject = "Validation de votre part "
            .Body = xMailBody
            .Display
        End With
        Set xRgSel = Nothing
        Set xOutApp = Nothing
        Set xMailItem = Nothing
    End If
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Merci