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

[Patrice740]

Bonjour,

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRgSel As Range, cel As Range, rng As Range
  '...
Sheets("A").Range("C:H").Copy
Sheets("A").Range("C:H").PasteSpecial xlPasteValues
  '...

C'est normal queça ne fonctionne pas, ton code n'est pas bon : tu copies des colonnes entières au lieu de copier uniquement la ligne concernée.

Tu devrais analyser chaque instruction du code que je t'ai proposé pour en comprendre le fonctionnement (Utilises F1).

D'autre par tu nommes la feuille "A", ce qui non seulement est inutile, mais est une source d'erreur potentielle pour deux raisons :
- Un objet Sheet ne contient par de Range, le Range appartient à Worksheet, donc Sheet("A").Range n'est pas une syntaxe correcte, même si elle fonctionne dans certains cas.
- Dans un module de feuille, lorsque la feuille n'est pas précisée un Range concerne la feuille dans laquelle se trouve la macro : si tu renommes la feuille, ça continue à fonctionner.
Il faut aussi éviter d'utiliser le presse papier (.Copy puis .Paste), c'est le rôle du rng.Value = rng.Value

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

Il n'y a pas de raison pour que ça fonctionne correctement, à moins d'avoir modifié le code que tu as publié !

Il fallait simplement modifier l'adresse des colonnes à copier, voici mon code intégré à ton ancienne macro :

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
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRgSel As Range, cel As Range, rng As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xMailBody As String
    Application.ScreenUpdating = False
    Set xRg = Range("AP1:AP200")
    Set xRgSel = Intersect(Target, xRg)
    If Not xRgSel Is Nothing Then
        Me.Unprotect 1234
        For Each cel In xRgSel.Cells
            If UCase(cel.Value) = "X" Then
                Set rng = Intersect(cel.EntireRow, Me.Columns("C:H"))
                rng.Value = rng.Value
                cel.EntireRow.Cells(1, "B").Value = "X"
            End If
        Next cel
        Me.Protect 1234
    End If
    Set xRgSel = Range("B4:B273")
    Set xRgSel = Intersect(Target, xRgSel)
    ActiveWorkbook.Save
    If Not xRgSel Is Nothing Then
        On Error Resume Next
        Application.DisplayAlerts = False
        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
        Application.DisplayAlerts = True
        On Error GoTo 0
    End If
    Application.ScreenUpdating = True
End Sub

[sylvain78]

Un grand merci à toi Patrice pour ton temps mais également pour tes explications très clairs !! MERCI

[sylvain78]

Bonjour à tous,

J'ai un problème avec ce code, en effet lors du copier/coller il me décale les valeurs situés entre H et V ?

A savoir j'ai des colonnes masqués à l'intérieur est-ce que ça serait un début de réponse ?

Merci