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

sylvain78b

XLDnaute Nouveau
Re(bonjour),

J'ai un dernier soucis avec mon classeur Excel.

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...

Est-ce possible ?

Merci beaucoup
 

Fichiers joints

sylvain78b

XLDnaute Nouveau
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 réussi avec ce code :

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

VB:
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
 
Dernière édition:

Discussions similaires


Haut Bas