Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

[anthooooony]

Bonjour

Je cherche à dispatcher une base de donnée par onglet grâce à un critère.

J'ai trouvé le moyen grâce au tableau croisé, une fois fait, avec en filtre de rapport il suffit de faire "afficher les filtres de rapport" on a autant d'onglet que ce trouve de critère. En l’occurrence, autant d'onglet que d'agence pour mon cas.

J'ai deux problème à ce principe:
* c'est qu'un TCD est lourd, j'ai prêt de 90 colonnes ce qui rend la mise en page du TCD assez complexe et peu lisible mais néanmoins possible.
*Il y a un problème de confidentialité, l'agence est sélectionnée en filtre de rapport, chaque utilisateur de son fichier pourrait sélectionner une autre agence car il garde tout en mémoire.

Je cherche donc à récupérer l'ensemble des informations liées à une agence(dernière colonne) comme si un filtre était fait.
Comme lorsqu'on fait connexion de donnée et qu'on a le choix entre récupérer le donnée en TCD ou tableau. Mon cas serait plutot en tableau.

Mon but final après est de dispatcher chaque onglet vers un dossier précis(code trouvé).
Pour ce que ça intéresse ci dessous le code.

Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 16/12/2011 par fl170417
'
'
Dim vnom, vdir As String
For Each Sheet In Sheets
Sheet.Select
vnom = ActiveSheet.Name
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
ChDir "N:\"
'choix du repertoire en fonction du nom agence
Select Case vnom
Case "Agence1": vdir = "Est\"
Case "Agence2": vdir = "Nord\"
Case "Agence3": vdir = "Nord\"
Case "Agence4": vdir = "Est\"
Case "Agence5": vdir = "Est\"
End Select
ActiveWorkbook.SaveAs Filename:="N:\" & vdir & vnom & " Période du " & Format(Date, "mm-yyyy") & ".xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveSheet.Name = vnom

ActiveWindow.Close savechanges = True
Application.DisplayAlerts = True
Next
End Sub

En vous remerciant pour l'aide que vous pourriez m'apporter.

Anthooooony

 

[bof]

Re : Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

Bonjour,
Dans la famille radin on a trouvé Anthoooony ! (Ton fichier joint est subliminaire...)
Ma solution risque d'être à retravailler grave. En tout cas elle répond exactement à ton fichier.

Sub Create_Ws()
Dim iLR&, iLC%, i%, ii&, k&, kk%, Tablo(), aRange()
iLR = Worksheets("Feuil1").Range("A1").CurrentRegion.Rows.Count
iLC = Worksheets("Feuil1").Range("A1").CurrentRegion.Columns.Count
'aRange est la ligne d'en-tête
aRange() = Range(Cells(1, 1), Cells(1, iLC))
  'Tablo est la liste des agences
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range(Cells(2, iLC), Cells(iLR, iLC))
    mondico(c.Value) = ""
  Next c
  Tablo = Application.Transpose(mondico.keys)
  
  'On crée chaque feuille
  For i = 1 To UBound(Tablo)
    Worksheets.Add.Name = Tablo(i, 1)
    Range(Cells(1, 1), Cells(1, iLC)) = aRange()
  Next

  'on remplit chaque feuille
  For i = 1 To UBound(Tablo)
  ii = 1
    With Feuil1
    For k = 2 To iLR
      If .Cells(k, iLC) = Tablo(i, 1) Then
      ii = ii + 1
        For kk = 1 To iLC
        Worksheets(Tablo(i, 1)).Cells(ii, kk) = .Cells(k, kk)
        Next
      End If
    Next
    End With
  Next
'YAPUKA dispatcher chaque onglet vers le dossier précis avec le code KIVABIEN
End Sub

A+

 

[Compte Supprimé 979]

Re : Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

Bonjour le fil,

De façon plus simple mais sans passer par un dictionnaire (qui ceci dis est une bonne idée )

Sub Dispatcher()
  Dim DLig As Long, Lig As Long, sAgence As String
  Dim Sht As Worksheet, sDir As String
' Avec la feuille nommée
  With Sheets("Feuil1")
    ' trouver la dernière ligne remplie du tableau
    DLig = .Range("D" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne du tableau
    For Lig = 2 To DLig
      sAgence = .Range("D" & Lig)
      ' Vérifier si la feuille existe, sinon la créer
      On Error Resume Next
      Sheets(sAgence).Activate
      If Err.Number <> 0 Then
        On Error GoTo 0
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = sAgence
        ' copier la ligne de titre dans la nouvelle feuille
        .Rows(1).Copy Destination:=ActiveSheet.Rows(1)
      End If
      On Error GoTo 0
      ' Copier la ligne actuelle dans la feuille
      .Rows(Lig).Copy Destination:=Sheets(sAgence).Rows(Sheets(sAgence).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row)
    Next Lig
  End With

' Déplacer chaque feuille dans un nouveau classeur à enregistrer
  For Each Sht In Sheets
    If Sht.Name = "Feuil1" Then GoTo Suite
    ' Déplacer dans un nouveau classeur
    Sht.Move
    ' Récupérer le nom de l'agence sur la 2ème ligne
    sAgence = ActiveSheet.Range("D2")
  'choix du repertoire en fonction du nom agence
  Select Case sAgence
    Case "Agence1": sDir = "Est\"
    Case "Agence2": sDir = "Nord\"
    Case "Agence3": sDir = "Nord\"
    Case "Agence4": sDir = "Est\"
    Case "Agence5": sDir = "Est\"
  End Select
  With ActiveWorkbook
    .SaveAs Filename:="N:\" & sDir & sAgence & " Période du " & Format(Date, "mm-yyyy") & ".xlsx", FileFormat:=xlNormal, _
      Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    .Close SaveChanges:=True
  End With
  ' Suite de la boucle
Suite:
  Next
  Application.DisplayAlerts = True
End Sub

A+

 

[anthooooony]

Re : Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

Bonjour à vous deux !

BrunoM45 ton code ne se lance pas, j'exécute il ne se passe rien, et je n'ai aucun message d'erreur c'est bizarre...

Bof ta solution est très bien, bon y'a juste à récupérer les mêmes couleurs que le fichier initial et le mois antérieur à celui annoncé à chaque extract mais ça c'est mon problème!!


Un grand merci encore

anthooooony

 

[Compte Supprimé 979]

Re : Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

Re,

Juste comme ça pour savoir ... tu lances le codes dans mon fichier joint ?
Ou tu le colles dans un autre et puis tu le lances ?

A+

 

[anthooooony]

Re : Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

Bonjour BrunoM45,

Désolé du retard, mais je ne reçois pas de notification lorsqu'on répond aux posts, je devrais regarder ça dans les parametres d'ailleurs si c'est possible..

J'ai lancé ton code dans ton fichier ET dans un nouveau en copiant le contenu des cellules plus en copiant tu codes.
Alors dans la premier cas rien ne se passe, et dans le deuxieme la macro se lance qu'une fois, et pour qu'elle se relance il faut recopier tout dans un autre classeur..

Bizarre bizarre

 

[JCGL]

Re : Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

Bonjour à tous,
Salut mon Nono,

Anthony : peux-tu essayer en mettant en commentaire GoTo Code2

Sub Dispatcher()
  Dim DLig As Long, Lig As Long, sAgence As String
  Dim Sht As Worksheet, sDir As String
  'GoTo Code2
  ' Avec la feuille nommée

A + à tous

 

[Compte Supprimé 979]

Re : Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

Re,

Merci mon JC j'ai oublié d'enlever cette ligne de test

A+

 

[anthooooony]

Re : Dispatcher par onglet l'ensemble des données BDD à partir d'un critère

Bonjour,

Ca marche mieux en mettant ' avant le go to... Encore merci JCGL et BrunoM45