Microsoft 365 Créer un onglet pour chaque thème contenant les titres en doublons associés à ce thème

Toucan72

XLDnaute Nouveau
Bonjour,

Je souhaiterais créer des feuilles ou des onglets distincts à partir de la colonne C (Thèmes) des documents en doublons. Chaque onglet serait dédié à un thème spécifique, comme la sociologie, la littérature, etc. Dans ces listes, doivent figurer tous les doublons (même titre en colonne H) qui se recoupent avec le thème en question (par exemple, tous les doublons qui concernent la sociologie doivent être listés dans l'onglet dédié à la sociologie).
Je vous remercie pour votre aide une fois de plus
Bonne après-midi
Toucan
 

Pièces jointes

  • Classeur3.xlsx
    12.2 KB · Affichages: 14

laurent950

XLDnaute Barbatruc
Bonjour Le Forum

En complément du Code #2
pour supprimer le bouton "GO" lors de la création des Onglets
Option :
- Connaitre le nom du bouton associé la procédure VBA = "Rectangle 1"
VB:
' Récupérer le nom du bouton associé
    Dim NomBouton As String
    If TypeName(Application.Caller) = "String" Then
        NomBouton = Application.Caller
        MsgBox "Le nom du bouton cliqué est : " & NomBouton
    End If
- Pour supprimer ce même bouton dupliqué lors de la création de l'onglet
Code:
' Supprimer la forme "G0" après duplication (si le bouton dupliqué existe)
        On Error Resume Next
            .Shapes(NomBouton).Delete
        On Error GoTo 0
 

Jeannette

XLDnaute Junior
Bonjour Le Forum

En complément du Code #2
pour supprimer le bouton "GO" lors de la création des Onglets
Option :
- Connaitre le nom du bouton associé la procédure VBA = "Rectangle 1"
VB:
' Récupérer le nom du bouton associé
    Dim NomBouton As String
    If TypeName(Application.Caller) = "String" Then
        NomBouton = Application.Caller
        MsgBox "Le nom du bouton cliqué est : " & NomBouton
    End If
- Pour supprimer ce même bouton dupliqué lors de la création de l'onglet
Code:
' Supprimer la forme "G0" après duplication (si le bouton dupliqué existe)
        On Error Resume Next
            .Shapes(NomBouton).Delete
        On Error GoTo 0
Bonsoir,
On peut aussi définir les propriétés de ce bouton avant de lancer la procédure
1727454563584.png

Il ne sera alors plus dupliqué
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Sorry.
Mais je suis sous 2007 et VBA6 et ce phénomène ne se produit pas. D'où ma question. :confused:
D'ailleurs je ne comprends pas comment cela se passe car :
1- Je crée un onglet vierge
2- Je filtre la table d'entrée
3- Je copie la plage filtrée sur l'onglet de destination.
Le collage se fait avec :
VB:
.[A1].CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(NouvelOnglet).[A1]
Je ne comprends pas comment cette ligne peut coller un objet. Pour moi elle ne devrait coller que des données.
 

laurent950

XLDnaute Barbatruc
Bonsoir @sylvanu

J'y avais pensé, mais si sur la feuille à copier il y a des Shapes existants dans le modèle, ils seront aussi effacés ?

Mais oui, cela efface bien tous les shapes d'un onglet
'For Each x In .Shapes: x.Delete: Next x ' Il n'y a pas besoin d'une boucle
.DrawingObjects.Delete ' En une seule fois
elle supprime tout shape de la feuille
 
Dernière édition:

laurent950

XLDnaute Barbatruc
3- Je copie la plage filtrée sur l'onglet de destination.
Voici pourquoi cela se produit :
  1. Liens entre Shapes et cellules : Dans Excel, les Shapes peuvent être ancrées ou associées à des cellules. Si une forme est ancrée à une cellule ou recouvre une cellule visible, elle peut être copiée en même temps que cette cellule.
  2. Position relative de la forme : Si la forme recouvre une plage de cellules, elle peut être incluse dans la sélection lorsque tu utilises .CurrentRegion.SpecialCells(xlCellTypeVisible). Excel considère parfois les objets superposés comme faisant partie de la plage sélectionnée
  3. Si tu souhaites uniquement copier les cellules sans les formes, tu pourrais envisager de désancrer les formes ou de les gérer séparément en utilisant le code pour les Shapes spécifiquement. Exemple en Poste #4 @Jeannette
 

laurent950

XLDnaute Barbatruc
Bonjour @sylvanu

Code VBA en relation avec le Poste #4 | "ne pas déplacer ou redimensionner avec les cellules"

plus besoin de cela : .DrawingObjects.Delete ' Suppression des Shapes

VB:
' Récupérer le Nom du bouton de la Macro VBA.
  Dim NomBouton As String ' Récupérer le nom du bouton associé
  If TypeName(Application.Caller) = "String" Then
      NomBouton = Application.Caller
     'MsgBox "Le nom du bouton cliqué est : " & NomBouton
    ' Ne pas déplacer ou redimensionner avec les cellules | variable --->> "xlFreeFloating"
      ActiveSheet.Shapes(NomBouton).Placement = xlFreeFloating
  End If
 
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
Bonjour à toutes & à tous, bonjour @Toucan72 , @sylvanu , @laurent950

Après l'heure, ce n'est plus l'heure ... Mais bon je propose quand même.
Je n'ai pas compris exactement la même chose que vous dans la demande de @Toucan72 :
Dans ces listes, doivent figurer tous les doublons (même titre en colonne H) qui se recoupent avec le thème en question (par exemple, tous les doublons qui concernent la sociologie doivent être listés dans l'onglet dédié à la sociologie
Je comprends que ça ne concerne que les doublons (ou plus) mais pas les livres en un seul exemplaire.
Pour bien faire, dans l'exemple fournis il n'y a que des doublons ... Bon j'ai ajouté un livre unique.
Je n'ai listé que les titres mais on pourrait, s'il le faut, mettre les autres informations (sans les thèmes déjà présent dans le nom de la feuille ??)

Pour les noms de feuille, j'ai traité les caractères non autorisés : / \ ? * [ ] comme @sylvanu l'a fait pour les virgules (mais j'ai laissé les virgules), et je les ai triées par ordre alphabétique.

J'ai transformé la liste complète en tableau structuré, et les listes de titres sont également des TS.

Dernier point : comme c'est pour Excel365, j'ai utilisé en vba les fonctions UNIQUE, TRIER et FILTRE ce qui limite l'utilisation aux version 2021 et 365.

Le code :
VB:
'CodeName de la feuille contenant la liste complète : Sh_ListeComplète
'Tableau structuré de la liste complète : "ListeLivres"

Sub ListeThème()
    
     Dim Tb(), Extraction(), Test(), ListeThèmes(), ListeTitres()
     Dim DicThèmeSh As Object, DicDoublonsSht As Object, DicTrié As Object
     Dim Titre, Thème, Filtre$, NomFeuille$
     Dim Sz As Long, Lb As Long, Ub As Long, i As Long
    
     Set DicThèmeSh = CreateObject("Scripting.dictionary")
     Set DicDoublonsSht = CreateObject("Scripting.dictionary")
     Set DicTrié = CreateObject("Scripting.dictionary")
    
     Application.ScreenUpdating = False
    
     With WorksheetFunction
          'Listes sans doublon
          ListeThèmes = .Sort(.unique(Sh_ListeComplète.[ListeLivres[Thèmes]]))
          ListeTitres = .unique(Sh_ListeComplète.[ListeLivres[Titre]])
          
          'Pour chaque doublon dans les titres, liste des thèmes correspondant
          For Each Titre In ListeTitres
               Filtre = "=ListeLivres[Titre]=""" & Replace(Titre, """", """""") & """"
               Test = Evaluate(Filtre)
               Extraction = .Filter(Sh_ListeComplète.[ListeLivres[Thèmes]], Test, "-")
               If UBound(Extraction) > 1 Then
                    For Each Thème In Extraction
                         If DicDoublonsSht.exists(Thème) Then
                              Tb = DicDoublonsSht(Thème)
                              Sz = UBound(Tb) + 1
                         Else
                              Sz = 1
                         End If
                         ReDim Preserve Tb(1 To Sz)
                         Tb(Sz) = Titre
                         DicDoublonsSht(Thème) = Tb
                    Next
               End If
          Next
     End With
    
     'Tri du dico dans l'ordre des thèmes
     Tb = DicDoublonsSht.keys
     Lb = LBound(Tb): Ub = UBound(Tb)
     Call tri(Tb, Lb, Ub)
     For i = Lb To Ub
          DicTrié(Tb(i)) = DicDoublonsSht(Tb(i))
     Next
    
     'Remplacement caractères non autorisés /\?*[] dans le nom des feuilles
     For i = 1 To UBound(ListeThèmes, 1)
          DicThèmeSh(ListeThèmes(i, 1)) = Replace(Replace(Replace(Replace(Replace(Replace(ListeThèmes(i, 1), "/", "_"), "\", "_"), "?", "_"), "*", "_"), "[", "_"), "]", "_")
     Next
    
     'Suppression des anciennes feuilles des thèmes
     Application.DisplayAlerts = False: On Error Resume Next
     For Each NomFeuille In DicThèmeSh.items
          ThisWorkbook.Worksheets(NomFeuille).Delete
     Next
     Application.DisplayAlerts = True: On Error GoTo 0
    
     'Création des feuilles thèmes pour les livres en doublon (ou plus)
     i = 0
     For Each Thème In DicTrié
          i = i + 1
          ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)).Name = DicThèmeSh(Thème)
          ActiveWindow.DisplayGridlines = False
          With ActiveSheet
               .Cells(1).Value = "Livre en doublons"
               Tb = DicDoublonsSht(Thème)
               nb = UBound(Tb)
               Cells(2, 1).Resize(nb).Value = Application.Transpose(Tb)
               With .ListObjects.Add(xlSrcRange, .Cells(1).Resize(nb + 1), , xlYes)
                    .TableStyle = "TableStyleLight14"
                    .Name = "tb_Thème_" & Format(i, "000")
               End With
               .Columns(1).EntireColumn.AutoFit
          End With
     Next
     Application.Goto Sh_ListeComplète.[ListeLivres]
     Application.ScreenUpdating = False
    
     Dim wsh As Worksheet
     wsh.d
    
End Sub


Sub tri(a(), gauc, droi)          ' Quick sort J. Boisgontier

     ref = a((gauc + droi) \ 2)
     g = gauc: d = droi
     Do
          Do While a(g) < ref: g = g + 1: Loop
          Do While ref < a(d): d = d - 1: Loop
          If g <= d Then
               temp = a(g): a(g) = a(d): a(d) = temp
               g = g + 1: d = d - 1
          End If
     Loop While g <= d
    
     If g < droi Then Call tri(a, g, droi)
     If gauc < d Then Call tri(a, gauc, d)
    
End Sub

Voir la pièce jointe

À bientôt
 

Pièces jointes

  • Liste Livres AtTheOne.xlsm
    34.1 KB · Affichages: 2

Discussions similaires

Statistiques des forums

Discussions
314 121
Messages
2 106 129
Membres
109 495
dernier inscrit
jerome bonneau