Macro copier/coller par rapport au numéro de ligne

Le 07/03/2019 à 09:07

Bonjour,

Je souhaite créer une macro qui copie/colle (pour effacer les formules recherches V) ma ligne active.

Dans l'exemple ci-joint, quand je clique sur la check box E4, j'ai un copier/coller des cellules B4: D4 + un "Oui" qui s'indique dans la cellule A4 + entrée à la fin.

Je souhaite le faire pour E5 sur les valeurs B5: D5 + Oui en cellule A5 + entrée à la fin, etc...

17macro-copier-coller.xlsx (13.54 Ko)

Est-ce possible ?

Merci beaucoup

Le 07/03/2019 à 13:00

Bonjour,

Dans l'exemple ci-joint, quand je clique sur la check box E4, j'ai un copier/coller des cellules B4: D4 + un "Oui" qui s'indique dans la cellule A4 + entrée à la fin.

il n'y a pas de macro dans le fichier que tu as joint,

Peux-tu montrer ta macro ?

Le 07/03/2019 à 13:35

Bonjour,

Bonjour i20100

Peux-tu indiquer dans ton profil, la version Excel utilisée ?

Cdlt.

Le 07/03/2019 à 17:29
i20100 a écrit :

Bonjour,

Dans l'exemple ci-joint, quand je clique sur la check box E4, j'ai un copier/coller des cellules B4: D4 + un "Oui" qui s'indique dans la cellule A4 + entrée à la fin.

il n'y a pas de macro dans le fichier que tu as joint,

Peux-tu montrer ta macro ?

Merci de ta réponse, j'ai essayé de changer de procéder par 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.

J'ai reussi avec ce code

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
[b]Sheets("A").Range("C:H").Copy
Sheets("A").Range("C:H").PasteSpecial xlPasteValues[/b]
rng.Value = rng.Value
cel.EntireRow.Cells(1, "B").Value = "X"
End If
Next cel
Me.Protect (1234) 
End Sub

Mais j'ai un problème avec le copier/coller car ça me copie colle les colonnes C à H alors que je voudrais uniquement de la ligne active.

Ex :

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

Le 07/03/2019 à 18:14

re,

tu peux remplacer le code

Sheets("A").Range("C:H").Copy
Sheets("A").Range("C:H").PasteSpecial xlPasteValues
rng.Value = rng.Value

par

With Sheets("A").Range("C" & Target.Row & ":H" & Target.Row)
 .Value = .Value
End With
Le 08/03/2019 à 09:12

Merci de ta réponse,

Malheureusement ça ne copie/colle rien

Le 08/03/2019 à 11:18

J'ai réussi avec ce code :

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  
End Sub

Mais j'ai un problème 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

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

Merci

Le 08/03/2019 à 15:06

re,

tu peux le mettre à la suite,

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, rng 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

    '2èm   cas

  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
End Sub
Le 26/06/2019 à 11:13

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

Rechercher des sujets similaires à "macro copier coller rapport numero ligne"