Repeter un enregistrement Macro sur les ligne suivante

Le 27/01/2021 à 11:18

Bonjour,

Je suis débutant sur Excel et je m'aide beaucoup des tutos et astuce que vous posté régulièrement.

Mais la j'ai un petit problème (pour vous je pense et gros pour moi) que je n'arrive pas a résoudre.

Je travail sur la création d'un fichier de gestion d'entrée/sortie de matériel, sur mon classeur j'ai deux feuille (liste des équipement et fil de suivi).

J'ai effectuer un enregistrement de macro de pour récupérer certaine info de la premier feuille afin d'alimenté mon fil de suivi sur la deuxième feuille avec un bouton de contrôle de formule a qui je lui ai affecté cette macro .

Mon problème est que j'ai plus de milles ligne et que je souhaiterai affecté ce bouton (et macro) a chaque ligne, et tout ca en choisissant la ligne que je viens de renseigné.

Voici le code de la macro que j'ai enregistré:

Sub ValidationDépart1()
'
' ValidationDépart1 Macro
'

'
Sheets("Fil de suivi").Select
Rows("3:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A3").Select
Sheets("Liste Matériels").Select
Range("C8").Select
Selection.Copy
Sheets("Fil de suivi").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Liste Matériels").Select
Range("N8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Fil de suivi").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Liste Matériels").Select
Range("O8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Fil de suivi").Select
Range("D3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Liste Matériels").Select
Range("P8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Fil de suivi").Select
Range("F3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Liste Matériels").Select
Range("Q8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Fil de suivi").Select
Range("G3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Liste Matériels").Select
Range("R8").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("R8").Select
End Sub

Merci de votre aide

Bonne journée

Le 29/01/2021 à 22:54

Bonjour,

Voici une proposition de code (A PLACER DANS LE MODULE DE LA FEUILLE "LISTE").

A chaque double-clic sur la feuille, elle s'exécutera (avec un message préalable de confirmation d'exécution).

On clic sur une ligne de Liste, On reporte les valeurs des cellules de cette ligne en colonnes C, N, O, P, Q à la première ligne non vide de "Fil" (colonnes A, B, D, F, G) puis on efface la cellule en R sur Liste.

private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)
cancel = true
ligne = target.row
if msgbox("Confirmez-vous la copie de la ligne " & ligne & " ?", vbyesno) = vbyes then
    set wsfil = Sheets("Fil de suivi")
    colfil = array(1, 2, 4, 6, 7)
    colliste = array(3, 14, 15, 16, 17)
    with wsfil
        nvl = .cells(.rows.count, 1).end(xlup).row + 1
        for k = lbound(colfil) to ubound(colfil)
            .cells(nvl, colfil(k)).value = Me.cells(ligne, colliste(k)).value
        next k
    end with
    Me.cells(ligne, 18).value = ""
end if

End Sub

Cdlt,

Le 01/02/2021 à 14:57

Bonjour 3GB,

Merci d'avoir pris le temps de me répondre et de m'avoir créer ce code.

Je viens de coller le code dans la feuille "liste" mais il copie la ligne dans l'entête des colonne de la feuille "FIL".

Il n'incrémente pas de nouvelle ligne sur la feuille.

Voici le tableau en Liens pour que tu puisse voir ce que j'ai exactement au niveau des deux boutons de validation de la ligne 8.

Et je souhaiterai faire la même chose sur les 1000 lignes qui suit

Merci de ton aide.

13gestion-stock-apparaux-ccg.xlsm (114.83 Ko)
Le 01/02/2021 à 21:07

Bonjour,

Il y avait un problème à cause des fusions de cellules sur les en-têtes de votre tableau. Règle d'or : ne jamais fusionner de cellules !

J'ai donc enlevé ces fusions, mis le tout sous forme de tableau structuré et adapté un peu le code. Normalement, ça devrait aller maintenant pour 1000 ou 100 000 lignes, ça copiera à chaque fois sur la première ligne non vide (tant qu'il n'y a pas de lignes vides intercalées entre des lignes non vides) et les restructurations seront automatiques.

J'ai remarqué qu'il y avait 2 fois 2 colonnes pour l'état du matériel. A mon avis, une seule suffit à chaque fois surtout s'il s'agit de mettre OK ou NOK mais je n'ai pas modifié.

Version antérieure supprimée

Cdlt,

Le 02/02/2021 à 11:43

Bonjour,

Merci pour la restructuration du tableau.

Je viens de faire des essais et ca fonctionne très bien.

le seul bémol (chose que j'ai complétement oublié de mentionné) c'est que sur la feuille "Liste" j'ai deux enregistrement et je viens de m'apercevoir que j'en ai mis qu'un seul.

Le deuxième sert au retour de matériel il enregistre comme le premier mais seulement la deuxième parti du tableau et une fois enregistré il efface les renseignement de la ligne concerné.

Au niveau de la feuille "suivi" il incrément une nouvelle ligne avec un enregistrement dans des colonne différente.

Cette fois-ci je mets les deux enregistrement complet.

Sub ValidationDépart1()
'
' ValidationDépart1 Macro
'

'
    Sheets("Fil de suivi").Select
    Rows("3:3").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A3").Select
    Sheets("Liste Matériels").Select
    Range("C8").Select
    Selection.Copy
    Sheets("Fil de suivi").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("N8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("B3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("O8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("D3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("P8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("F3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("Q8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("G3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("R8").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = ""
    Range("R8").Select
End Sub
Sub ValidationRetour1()
'
' ValidationRetour1 Macro
'

'
    Sheets("Fil de suivi").Select
    Rows("3:3").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A3").Select
    Sheets("Liste Matériels").Select
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Range("C8").Select
    Selection.Copy
    Sheets("Fil de suivi").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("S8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("C3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("T8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("E3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("U8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("H3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("V8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("I3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("W8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("J3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("X8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Fil de suivi").Select
    Range("K3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Liste Matériels").Select
    Range("N8:X8").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("N8").Select
End Sub

Désoler de cette oubli qui est important;

Cdlt,

Le 02/02/2021 à 12:07

Bonjour,

Ces 2 lignes :

    colfil = array(1, 2, 4, 6, 7)
    colliste = array(3, 14, 15, 16, 17)

permettent de définir les colonnes de destination (colfil) et les colonnes d'origine (colliste).

Il suffit d'adapter. Par exemple (je ne dis pas que ça correspond à votre attente) :

    colfil = array(1, 2, 4, 6, 7, 8) 'A, B, D, F, G, H
    colliste = array(3, 14, 15, 16, 17, 18) 'C, N, O, P, Q, R

Ici, la colonne A de "fil" recoit la colonne C de "liste", B recoit N, D recoit O, ...., H recoit R.

Il faut juste que les 2 array soient de même dimension.

Merci de clôturer le sujet si le problème est résolu.

Cdlt,

Le 03/02/2021 à 08:17

Bonjour,

Merci beaucoup pour ce code.

Petite question (Je suis casse pied), peut-on affecté ce code a un bouton?

Merci de ton retour.

Cdlt

Le 03/02/2021 à 09:01

Bonjour,

Ce code là, on ne peut pas l'affecter à un bouton parce qu'il s'agit d'une macro évènementielle qui se déclenche, non pas au clic sur un bouton, mais au double-clic sur une cellule. A moins que le besoin n'ait évolué entre temps, je pense que le double-clic est à privilégier car il permet d'avoir une seule procédure, qui variabilise la ligne à copier, sous un même évènement. Sinon, il faudrait une multitude de boutons (ce n'est pas top) et adapter le code en conséquence (beaucoup d'efforts pour un moins bon rendement).

Cdlt,

Le 03/02/2021 à 09:19

OK, Mais comment je peux différencier mes deux enregistrement?

Le 03/02/2021 à 09:26

Ah oui, c'est vrai ! Il vous faut 2 enregistrements. Je vais modifier le code de manière à gérer ça mais il faudra que vous saisissiez vous-même les colonnes de destination et d'origine du second enregistrement.

A bientôt,

Le 03/02/2021 à 09:57

Re,

Voici le fichier avec un code qui s'exécute toujours au double clic mais qui dépend de la zone du clic.

Dans la macro doubleclick, on va définir, pour chaque zone, les colonnes de destination et d'origine et on va les rentrer en paramètres de la macro commune appelée copie.

Si le double-clic a lieu sur A:M, les colonnes 3, 14, ... sont copiées sur les colonnes 1, 2, 4, 6, 7 de Suivi, sinon, ce sont d'autres colonnes qui sont copiées (c'est à vous de faire les petits changements) sachant que la colonne 1 ("A") de Suivi est fondamentale pour la bonne exécution du code. Il faut qu'elle soit alimentée à chaque fois.

Private Sub worksheet_beforedoubleclick(ByVal target As Range, cancel As Boolean)

cancel = True

If Not Intersect(target, Range("A:M")) Is Nothing Then
    tColonnesListe = Array(3, 14, 15, 16, 17) 'origine à définir
    tColonnesSuivi = Array(1, 2, 4, 6, 7) 'destination à définir
    Call copie(target, tColonnesListe, tColonnesSuivi) 'macro commune exécutée en fonction de ces paramètres ci-avant
ElseIf Not Intersect(target, Range("N:Y")) Is Nothing Then
    tColonnesListe = Array(3, 14, 15, 19, 20) 'origine
    tColonnesSuivi = Array(1, 2, 4, 8, 9) 'destination
    Call copie(target, tColonnesListe, tColonnesSuivi)
End If

End Sub

Sub copie(rcible As Range, ColonnesOrigine, ColonnesDestination)

ligne = rcible.Row

If MsgBox("Confirmez-vous la copie de la ligne " & ligne & " ?", vbYesNo) = vbYes Then
    With Sheets("Fil de suivi").Range("Suivi")
        nvl = .Rows.Count - Application.CountBlank(.Columns(1)) + 1
        For k = LBound(ColonnesDestination) To UBound(ColonnesDestination)
            .Cells(nvl, ColonnesDestination(k)).Value = Sheets("Liste Matériels").Cells(ligne, ColonnesOrigine(k)).Value
        Next k
    End With
    Sheets("Liste Matériels").Cells(ligne, 18).Value = ""
End If

End Sub
26gestion-stock-apparaux-ccg.xlsm (115.30 Ko)

Cdlt,

Le 03/02/2021 à 10:28

Re,

Merci beaucoup,

Je viens de faire la modification des cellules a copier et a coller.

Dernière question (Après je ne t'embête plus) Peut-on dans la fin du code du second enregistrement on peut rajouter l'effacement de la ligne copier. ou mettre une foction dans la fentre de validation une case a cocher pour valider l'éffacement des colonnes (N à Y)

Merci

Le 03/02/2021 à 10:30

En ajoutant cette ligne normalement :

Private Sub worksheet_beforedoubleclick(ByVal target As Range, cancel As Boolean)

cancel = True

If Not Intersect(target, Range("A:M")) Is Nothing Then
    tColonnesListe = Array(3, 14, 15, 16, 17) 'origine à définir
    tColonnesSuivi = Array(1, 2, 4, 6, 7) 'destination à définir
    Call copie(target, tColonnesListe, tColonnesSuivi) 'macro commune exécutée en fonction de ces paramètres ci-avant
ElseIf Not Intersect(target, Range("N:Y")) Is Nothing Then
    tColonnesListe = Array(3, 14, 15, 19, 20) 'origine
    tColonnesSuivi = Array(1, 2, 4, 8, 9) 'destination
    Call copie(target, tColonnesListe, tColonnesSuivi)
    range("N:Y").rows(target.row).clearcontents
End If

End Sub

Décidément, tu veux vraiment rajouter des boutons et des cases à cocher

Cdlt,

Le 03/02/2021 à 10:38

Magnifique

Merci Beaucoup

tout fonctionne.

Merci encore.

Cdlt

Le 03/02/2021 à 10:50

Merci pour ce chaleureux retour ! Je suis content qu'on y soit parvenus.

Bonne continuation à toi,

Cdlt,

Rechercher des sujets similaires à "repeter enregistrement macro ligne suivante"