éclater une base de données en onglets en fonction des occurences d'une colonne

stephcic · 23 Mars 2016

Bonjour à tous,
je suis confronté à un besoin pour lequel je ne trouve pas de réponse.
Voilà, on me communique tous les mois un fichier avec une base de données.
Et j'aimerais éclater cette base en différents onglets en fonction des occurrences d'une colonne
En pièce joint un exemple simple
Merci pour votre aide et longue vie à ce forum génial.
STEPH

Celeda · 23 Mars 2016

Re : éclater une base de données en onglets en fonction des occurences d'une colonne

Bonjour,

Façon tcd : faire un tableau croisé dynamique et cliquer sur chaque total pour création de mini-bases de données récapitulatives.

Caillou · 23 Mars 2016

Re : éclater une base de données en onglets en fonction des occurences d'une colonne

Bonjour à tous,

Solution utilisant une zone de critères et un filtre avancé en VBA:

Code:

Sub Occurence_Colonnne_C()
  Dim mon_crt As String
  Dim nb_oc As Integer
  Dim i As Integer
  
  'doublons
  Application.ScreenUpdating = False
  Sheets("Vue globale").Select
  Columns("C:C").Copy
  Sheets.Add After:=Sheets(Sheets.Count)
  ActiveSheet.Name = "Critères"
  ActiveSheet.Paste
  Application.CutCopyMode = False
  Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
  Range("A2").Select
  nb_oc = ActiveCell.CurrentRegion.Cells.Count - 1
  
  'boucles sur critères
  For i = 1 To nb_oc
    mon_crt = ActiveCell.Value
    ActiveCell.Value = "=""=" & mon_crt & """"
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = mon_crt
    Sheets(mon_crt).Select
    Sheets("Vue globale").Columns("A:Q").AdvancedFilter Action:=xlFilterCopy, _
          CriteriaRange:=Sheets("Critères").Range("A1:A2"), CopyToRange:=Range("A1") _
          , Unique:=True
    Sheets("Critères").Select
    Selection.Delete Shift:=xlUp
  Next

  'suppr crt
  Application.DisplayAlerts = False
  Sheets("Critères").Delete
End Sub

Caillou

éclater une base de données en onglets en fonction des occurences d'une colonne

stephcic

XLDnaute Junior

Pièces jointes

Celeda

XLDnaute Barbatruc

Pièces jointes

Caillou

XLDnaute Impliqué

Discussions similaires