Ajouter date à un déplacement par VBA

Bonjour

J'ai une macro pour archiver des lignes qui fonctionne :

Sub Archiver()

'

' Archiver Macro

'

Dim lig As Integer

Dim lig2 As Integer

With Worksheets("Effectif")

For lig = .Range("D65536").End(xlUp).Row To 2 Step -1

lig2 = Sheets("Archives").Range("D65536").End(xlUp).Row

If .Range("AX" & lig).Value = "ü" Then

.Rows(lig).Cut Sheets("Archives").Rows(lig2 + 1)

.Rows(lig).Value = ""

End If

Next

End With

End Sub

Je voudrais qu'une messagebox me demande la date de départ de la personne est l'inscrive dans la cellule "AY" de la ligne nouvellement créée.

le script serait à partir de cela :

depart = inputbox ("A quelle date est parti le jeune ?", "Date de départ")

range("$AY").value = depart

Comment inscrire ce second code dans le premier ?

Bonjour,

Peut-être tout simplement comme ça:

Range("AY1") = InputBox("A quelle date est parti le jeune ?", "Date de départ")

cdt

Merci de ton aide.

Mais comment faire pour que cette date ce mette en fin de ligne collée ?

Et ou mettre ce code ?

re,

il faudrait connaitre un peu plus ton code.

Cette ligne doit etre en amont de l'utilisation de la date.

Sinon la coordonnée de la position de la date dépend de la configuation des données présentent sur ta feuille.

Le mieux serait de fournir un fichier exemple ou mieux ton fichier anonymé.

Cdt

dernierecolonne = cells(1, columns.count).end(xltoLeft).column + 1 

A adapter en fonction de ta feuille. Là c'est pour la ligne 1.

cdt

Voila

Il est censé faire quoi ton code car il n'y a rien en AX63.

Explique tes attentes.

quand je selectionne une ligne via la case AX, le symbole cocher apparaît.

De là, si je clique sur le bouton archiver, la ligne entière est déplacée vers la feuille "archives". Je veux que sur cette dernière, en fin de ligne nouvellement déplacée, apparaisse la date de départ du jeune, date demandée par une messagebox

Voila l’idée va voir la macro

Toukoul

Super, mais la macro ne deplace pas sur la feuille archives mais la repositionne sur la feuille1

le mieux serait de mette le code dans la feuille Effectif

cdt

J'ai repris la macro, sait tu t'en servir?

Il faut l'adapter à ton problème

un double clic sur la ligne à archiver en colonne AX.

Test avec des données.

Cdt

Je l'ai modifiée ainsi

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Application.Intersect(Target, Range("AX3:AX65 ")) Is Nothing Then

With Target

With .Font

.Name = "Wingdings"

.Size = 10

.Bold = True

End With

.Value = IIf(.Value = "", "ü", "")

End With

' Archiver Macro

'

Dim DerL As Integer

Dim shA As Worksheet

Set shA = Sheets("Archives")

DerL = shA.Range("Ax" & Rows.Count).End(xlUp).Row + 1

With Worksheets("Effectif")

.Range(.Cells(Target.Row, "A"), .Cells(Target.Row, "AW")).Copy shA.Range("A" & DerL)

With Worksheets("Archives")

.Range("AY" & DerL) = InputBox("A quelle date est parti le jeune ?", "Date de départ")

End With

End With

Cancel = True

End If

End Sub

Par contre la ligne de base ne s'efface plus.

J'ai fait une modif.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Application.Intersect(Target, Range("AX3:AX65 ")) Is Nothing Then
   With Target
      With .Font
         .Name = "Wingdings"
         .Size = 10
         .Bold = True
      End With
   .Value = IIf(.Value = "", "ü", "")
   End With
   ' Archiver Macro
   '
   Dim DerL As Integer
   Dim shA As Worksheet
   Set shA = Sheets("Archves")
   DerL = shA.Range("Ax" & Rows.Count).End(xlUp).Row + 1

   With Worksheets("Effectif")
      .Range(.Cells(Target.Row, "A"), .Cells(Target.Row, "AW")).Copy shA.Range("A" & DerL)
      shA.Range("AY" & DerL) = InputBox("A quelle date est parti le jeune ?", "Date de départ")
      .Cells(Target.Row).Delete
   End Sub

Cancel = True
End If

End Sub

Suppression de la ligne et modif sur l'écriture de la date car elle n’inscrivez sur la feuille effectif

Cdt

erreur 1004, le déplacement de cellule dans un tableau ... n'est pas autorisé...

=> .Cells(Target.Row).Delete

Validé :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Application.Intersect(Target, Range("AX3:AX65 ")) Is Nothing Then

With Target

With .Font

.Name = "Wingdings"

.Size = 10

.Bold = True

End With

.Value = IIf(.Value = "", "ü", "")

End With

' Archiver Macro

'

Dim DerL As Integer

Dim shA As Worksheet

Set shA = Sheets("Archives")

DerL = shA.Range("Ax" & Rows.Count).End(xlUp).Row + 1

With Worksheets("Effectif")

.Range(.Cells(Target.Row, "A"), .Cells(Target.Row, "AW")).Copy shA.Range("A" & DerL)

shA.Range("AY" & DerL) = InputBox("A quelle date est parti le jeune ?", "Date de départ")

ActiveCell.EntireRow.Delete

'.Range("AX" & lig).Select

End With

Cancel = True

End If

End Sub

voilà

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Application.Intersect(Target, Range("AX3:AX65 ")) Is Nothing Then
   With Target
      With .Font
         .Name = "Wingdings"
         .Size = 10
         .Bold = True
      End With
   .Value = IIf(.Value = "", "ü", "")
   End With
   ' Archiver Macro
   '
   Dim DerL As Integer
   Dim shA As Worksheet
   Set shA = Sheets("Archives")
   DerL = shA.Range("Ax" & Rows.Count).End(xlUp).Row + 1

   With Worksheets("Effectif")
      .Range(.Cells(Target.Row, "A"), .Cells(Target.Row, "AW")).Copy shA.Range("A" & DerL)
      shA.Range("AY" & DerL) = InputBox("A quelle date est parti le jeune ?", "Date de départ")
      .Rows(Target.Row).Delete
   End With

Cancel = True
End If

End Sub

Comme tu peux le constater sans pouvoir tester, on fait des petites erreurs.

cdt

Comme l'a dit EDISON (rappel de ma signature), tu n'as pas fait d'erreur, tu as juste trouvé une manière de faire qui ne fonctionne pas

Encore merci