Modification d'un programme

Le 28/07/2021 à 19:24

Bonjour, j'ai récupéré un brouillon d'un planning avec le programme qui fonctionne dans le planning que j'utilise actuellement. je ne suis pas très bon en codage, je voulais savoir si c'est possible de modifier le programme actuel.

Son fonctionnement : lorsque l'on double clic sur une cellule dans notre planning où se trouve la référence d'un produit un pop up apparait. dans ce pop up ce trouve les caractéristiques extraites d'une autre feuille (Feuille extraction). actuellement le programme permet l'extraction des données seulement d'une feuille et je voulais savoir comment faire pour qu'il le fasse pour 2, 3 ou 4 feuilles même si 2 feuilles me suffirai amplement.

Je ne sais pas si j'ai bien expliqué mon problème, si vous avez des question pour que je clarifie quelques points allez-y 

Sub Show_Produit()
Dim Cell    As Range
Dim Target  As Range
Set Target = Selection
    Set Cell = Feuil4.Columns(1).Find(Target)
    If Not Cell Is Nothing Then
        With ListBox1
            .Clear
            .Top = Target.Top + Target.Height
            .Left = Target.Left
             W = "85;140;40;40;40;40;80;80;80"
                .ColumnWidths = W
                .Width = 20 + Evaluate(Replace(W, ";", "+"))
            If Cell.MergeCells Then ' surtout pas de IIF
                N = Cell.MergeArea.Rows.Count
            Else
                N = 1
            End If
            .Height = Cell.RowHeight * (N + 1)
            .List = Cell.Resize(N, 9).Value
            .AddItem , 0 ' titre
                For I = 1 To Feuil4.[A2:I2].Cells.Count
                    .List(0, I - 1) = Feuil4.[A2:I2].Cells(I)
                Next
            .ListIndex = 0
            .Visible = True
            .Activate
        End With
    End If
End Sub
Private Sub ListBox1_LostFocus()
On Error Resume Next
    ListBox1.Visible = False
    Selection.Activate
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Select Case True
        Case Target = vbNullString
        Case LCase(Me.Range("C" & Target.Row)) <> "produit"
        Case Me.Cells(8, Target.Column).Formula <> vbNullString
        Case Else
            Show_Produit
            Cancel = True
    End Select
End Sub
9programme-sem-test.xlsm (94.34 Ko)
Le 28/07/2021 à 22:38

Hello,

Si tu veux faire simple et sans trop te prendre la tête tu peux copier coller le code d'une feuille (ici Feuil4) et remplacer Feuil4 par Feuil2.

Ce qui donnerai :

Sub Show_Produit()
Dim Cell    As Range
Dim Target  As Range
Set Target = Selection
    Set Cell = Feuil4.Columns(1).Find(Target)
    If Not Cell Is Nothing Then
        With ListBox1
            .Clear
            .Top = Target.Top + Target.Height
            .Left = Target.Left
             W = "85;140;40;40;40;40;80;80;80"
                .ColumnWidths = W
                .Width = 20 + Evaluate(Replace(W, ";", "+"))
            If Cell.MergeCells Then ' surtout pas de IIF
                N = Cell.MergeArea.Rows.Count
            Else
                N = 1
            End If
            .Height = Cell.RowHeight * (N + 1)
            .List = Cell.Resize(N, 9).Value
            .AddItem , 0 ' titre
                For I = 1 To Feuil4.[A2:I2].Cells.Count
                    .List(0, I - 1) = Feuil4.[A2:I2].Cells(I)
                Next
            .ListIndex = 0
            .Visible = True
            .Activate
        End With
    End If

Set Cell = Feuil2.Columns(1).Find(Target)
    If Not Cell Is Nothing Then
        With ListBox1
            .Clear 'cette ligne est à enlever si on veut garder l'existant
            .Top = Target.Top + Target.Height
            .Left = Target.Left
             W = "85;140;40;40;40;40;80;80;80"
                .ColumnWidths = W
                .Width = 20 + Evaluate(Replace(W, ";", "+"))
            If Cell.MergeCells Then ' surtout pas de IIF
                N = Cell.MergeArea.Rows.Count
            Else
                N = 1
            End If
            .Height = Cell.RowHeight * (N + 1)
            .List = Cell.Resize(N, 9).Value
            .AddItem , 0 ' titre
                For I = 1 To Feuil2.[A2:I2].Cells.Count
                    .List(0, I - 1) = Feuil2.[A2:I2].Cells(I)
                Next
            .ListIndex = 0
            .Visible = True
            .Activate
        End With
    End If

End Sub
Private Sub ListBox1_LostFocus()
On Error Resume Next
    ListBox1.Visible = False
    Selection.Activate
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Select Case True
        Case Target = vbNullString
        Case LCase(Me.Range("C" & Target.Row)) <> "produit"
        Case Me.Cells(8, Target.Column).Formula <> vbNullString
        Case Else
            Show_Produit
            Cancel = True
    End Select
End Sub
Le 29/07/2021 à 10:30

Merci, cela est simple mais efficace !!!

je voulais aussi savoir comment faire pour demander au programme si l'on clic droit de lancer tel module ou si l'on fait un double clic d'en lancer un autre

Le 29/07/2021 à 10:33

Salut, tu peux utiliser les évènements :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 
' Pour le double clic

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
' Pour le clic droit

Bibu

Le 29/07/2021 à 10:45

Merci de ta réponse mais je ne peux pas appeler un module avec,....

si tu préfère j'ai 2 programme que j'ai mis dans 2 différent module et je voudrai qu'avec le clic droit ce soit le programme dans le module 1 qui se lance et si j'utilise le double clic ce soit le module 2 qui se lance.

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
' Pour le double clic
 Call Module1
        End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Pour le clic droit
            Call Module2
        End Sub

j'ai essayé comme ceci mais ça me dit qu'il est impossible d'appeler un module

Le 29/07/2021 à 10:47

Il faut que tu appelle la procédure (Sub) ou bien la Fonction située dans le module, pas le module en entier

Le 29/07/2021 à 10:58

Merci à vous, mais cela ne fonctionne toujours pas,...

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
' Pour le double clic
 Call Job
        End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Pour le clic droit
            Call Show_Produit
        End Sub

J'ai tapé ce code et il me dit que ma sub n'est pas définie alors qu'elle l'ai bien, vous avez une idée ?

Option Explicit

Dim b As Byte

Private Sub Job(ref$, k As Byte)
  Dim s1$, s2$, c As Range, n1 As Byte, n2 As Byte, lig&
  If k = 9 Then s2 = "E-test" Else s1 = " 2": s2 = "API ATB"
  Set c = Worksheets("tableau à extraire" & s1).Columns(1).Find(ref, , -4163, 1, 1)
  If c Is Nothing Then b = 0: Exit Sub
  With Worksheets(s2)
    n1 = c.MergeArea.Rows.Count: b = 1: lig = .Cells(Rows.Count, 1).End(3).Row
    n2 = .Cells(lig, 1).MergeArea.Rows.Count: c.Resize(n1, k).Copy .Cells(lig + n2, 1)
    MsgBox "« " & ref & " » a été écrit" & vbLf & "en feuille " _
      & s2 & ".", 64, "Réf " & IIf(s1 = "", s2, "API")
  End With
End Sub

Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  Cancel = True
  With Target
    If .CountLarge > 1 Then Exit Sub
    Dim col%: col = .Column: If col < 5 Or col > 13 Or col Mod 2 = 0 Then Exit Sub
    Dim lig&: lig = .Row: If lig < 15 Or lig > 60 Or lig Mod 5 > 0 Then Exit Sub
    Dim ref$: ref = .Value
    If ref = "" Then MsgBox "Il n'y a pas de référence.", 48, "Cellule vide": Exit Sub
  End With
  Job ref, 9: If b = 0 Then Job ref, 29
  If b = 0 Then MsgBox _
    "« " & ref & " » est dans aucun des 2 tableaux.", 48, "Réf non trouvée"
End Sub

cela viendrai t'il de mon programme ?

Le 29/07/2021 à 11:44

Il faut passer le Sub en Public et non en Private

Rechercher des sujets similaires à "modification programme"