Macro copier/coller par rapport au numéro de ligne
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...
Est-ce possible ?
Merci beaucoup
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 ?
Bonjour,
Bonjour i20100
Peux-tu indiquer dans ton profil, la version Excel utilisée ?
Cdlt.
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.
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
Merci de ta réponse,
Malheureusement ça ne copie/colle rien
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
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
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