XL 2013 gestion d'onglets et afficher dans nouveau classeur ou onglet

kev2246

XLDnaute Nouveau
Bonjour,

Je viens de débuter la programmation sous vba donc autant vous dire que je ne suis pas encore à l'aise. Voilà mon soucis :
J'ai un fichier excel qui contient deux onglets :
1er onglet: composants+fonctions
2e onglet : fonctions+prescriptions

Un composant peut appartenir à plusieurs fonctions. une prescription peut couvrir plusieurs fonctions également.

J'aimerais faire tourner une macro qui ira cherchée l'information dans les différents onglets pour les afficher soit dans un nouveau classeur ou un nouvel onglet.
En gros, en fonction du composant choisit par l'utilisateur, j'aimerais qu'il m'affiche toutes les fonctions qui sont associées ainsi que les prescriptions associées à ces fonctions. Je dois avoir au moins 10000 composants à traiter et j'aimerais bien automatiser tout ça.

Je vous joins mon fichier test et vous remercie d'avance pour votre aide !
 

Pièces jointes

  • Classeur2.xlsx
    8.8 KB · Affichages: 12
Solution
Bonjour,

Voici le code modifié. J'ai commenté les lignes ajoutées.

VB:
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tabl1 As Variant, Tabl2 As Variant, I As Long, J As Long
  Dim L1 As Long, L2 As Long, Ligne As Variant
  If Target.Address = "$D$2" Then
    Application.EnableEvents = False
    Range("E2", Cells(Rows.Count, 6).End(xlUp)).Offset(1) = ""
    Tabl1 = Range("A2", Cells(Rows.Count, 2).End(xlUp))
    With Sheets("fonctions_prescription")
      Tabl2 = .Range("A2", .Cells(.Rows.Count, 2).End(xlUp))
    End With
    With Sheets("prescriptions_creneaux")
      L1 = 1
      For I = 1 To UBound(Tabl1, 1)
        If Tabl1(I, 1) = Target Then
          L1 = L1 + 1
          Cells(L1, 5) = Tabl1(I, 2)
          L2 = L1 -...

danielco

XLDnaute Accro
J'ai mis la liste déroulante en D2 sur la feuille "fonctions_prescription".

J(ai ajouté cette macro dans le module Thisworkbook pour réinitialiser la liste déroulante à l'ouverture du classeur :

VB:
Private Sub Workbook_Open()
  Dim Dico As Object, C As Range, Txt As String
  With Sheets("fonctions_prescription")
    Set Dico = CreateObject("Scripting.Dictionary")
    For Each C In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
      If Not Dico.exists(C.Value) Then
        Dico.Add C.Value, C.Value
        Txt = Txt & "," & C.Value
      End If
    Next C
    Txt = Right(Txt, Len(Txt) - 1)
    With .[D2].Validation
      .Delete
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
      xlBetween, Formula1:=Txt
    End With
  End With
End Sub

La macro est :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tabl1 As Variant, Tabl2 As Variant, I As Long, J As Long
  Dim L1 As Long, L2 As Long, Ligne As Variant
  If Target.Address = "$D$2" Then
    Application.EnableEvents = False
    Range("E2", Cells(Rows.Count, 5).End(xlUp)).Resize(, 9) = ""
    Tabl1 = Range("A2", Cells(Rows.Count, 2).End(xlUp))
    With Sheets("composants_fonctions")
      Tabl2 = .Range("A2", .Cells(.Rows.Count, 2).End(xlUp))
    End With
    With Sheets("prescriptions_creneaux")
      L1 = 1
      For I = 1 To UBound(Tabl1, 1)
        If Tabl1(I, 1) = Target Then
          L1 = L1 + 1
          Cells(L1, 5) = Tabl1(I, 2)
          L2 = L1 - 1
          For J = 1 To UBound(Tabl2, 1)
            If Tabl2(J, 2) = Tabl1(I, 2) Then
              L2 = L2 + 1
              Cells(L2, 6) = Tabl2(J, 1)
              '"Ligne" récupère la ligne de la prescription sur la feuille prescriptions_creneaux
              Ligne = Application.Match(Target.Value, .[A:A], 0)
              'Si la prescription est trouvée, on copie les informations
              If IsNumeric(Ligne) And L2 = 2 Then
                .Range(.Cells(Ligne, 2), .Cells(Ligne, .Columns.Count).End(xlToLeft)).Copy
                Cells(L2, 7).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
              End If
            End If
          Next J
        End If
      Next I
    End With
    Application.EnableEvents = True
  End If
End Sub

Daniel
 

Pièces jointes

  • Classeur2-1.xlsm
    30.2 KB · Affichages: 5

kev2246

XLDnaute Nouveau
Bonjour Daniel,

Peut-être que je me suis mal exprimé. en fait derrière les P1, P2, P3 et P4 se cachent des phrases du genre "les joueurs doivent être présents"...Pour des raisons de confidentialité je ne peux partager ces prescriptions.

J'ai simplement remplacé les P1, P2...par des phrases (cf fichier joint). Ensuite, j'ai modifié le menu déroulant des prescriptions en sélectionnant les données dans la colonne A (prescriptions) de l'onglet "fonction prescription". Et dans l'affichage des résultats, il y a des composants qui apparaissent alors qu'ils appartiennent même pas à la fonction (notamment les derniers composants ne changent pas quelque soit la prescription qu'on choisit).

Je te renvoie le fichier joint avec les phrases que j'ai remplacées.
 

Pièces jointes

  • classeur-modifié.xlsm
    23.7 KB · Affichages: 3

danielco

XLDnaute Accro
Effectivement, il y a un problème d'effacement. Par contre, pour la première anomalie, peux-tu me donner un exemple ?

VB:
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tabl1 As Variant, Tabl2 As Variant, I As Long, J As Long
  Dim L1 As Long, L2 As Long, Ligne As Variant
  If Target.Address = "$D$2" Then
    Application.EnableEvents = False
    Range("F2", Cells(Rows.Count, 6).End(xlUp)).Resize(, 8) = ""
    Tabl1 = Range("A2", Cells(Rows.Count, 2).End(xlUp))
    With Sheets("composants_fonctions")
      Tabl2 = .Range("A2", .Cells(.Rows.Count, 2).End(xlUp))
    End With
    With Sheets("prescriptions_creneaux")
      L1 = 1
      For I = 1 To UBound(Tabl1, 1)
        If Tabl1(I, 1) = Target Then
          L1 = L1 + 1
          Cells(L1, 5) = Tabl1(I, 2)
          L2 = L1 - 1
          For J = 1 To UBound(Tabl2, 1)
            If Tabl2(J, 2) = Tabl1(I, 2) Then
              L2 = L2 + 1
              Cells(L2, 6) = Tabl2(J, 1)
              '"Ligne" récupère la ligne de la prescription sur la feuille prescriptions_creneaux
              Ligne = Application.Match(Target.Value, .[A:A], 0)
              'Si la prescription est trouvée, on copie les informations
              If IsNumeric(Ligne) And L2 = 2 Then
                .Range(.Cells(Ligne, 2), .Cells(Ligne, .Columns.Count).End(xlToLeft)).Copy
                Cells(L2, 7).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
              End If
            End If
          Next J
        End If
      Next I
    End With
    Application.EnableEvents = True
  End If
End Sub

Daniel
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 926
Membres
101 841
dernier inscrit
ferid87