Scinder tableau en plusieurs classeur selon critères et en gardant la mise

Le 02/02/2018 à 13:59

Bonjour à toutes et à tous,

Tout nouveau sur le Forum j'espère pouvoir trouver mon bonheur

Voici ma problématique :

Je dispose d'un fichier (voir PJ) que j'aimerai scinder en plusieurs feuilles - pas de création de nouveaux onglets mais bien de nouveaux fichiers bien à part, bon si une macro est dispo pour générer les onglets, à défaut j'accepterai - correspondant à des projets donnés.

  • Le critère à utiliser pour générer les nouvelles feuilles est donc le critère "Projet" (colonne C, 2ème ligne : "Projet" - ex. Projet1, Projet2 etc...). avec comme output 1 feuille par projet.
  • Note : toutes les colonnes et leur contenu doivent être repris ainsi que la mise général du tableau (incluses les MFC).

En fouillant sur les forums, je n'arrive pas à trouver exactement ce que je cherche... soit je cherche mal soit je n'ai pas de chance !

Je cherche vraiment la solution presse bouton, un code à copier-coller, un bouton à créer et hop. Je sais qu'il existe des macros capables de le faire donc je garde espoir.

Aujourd’hui je passe par un filtre standard, un copier-coller projet par projet et un copier-coller mise en forme pour chaque projet... pas très rapide.

Merci pour votre aide et à bientôt

Amicalement,

Alex

30projets.xlsx (446.81 Ko)
Le 02/02/2018 à 14:17

bonjour

tu veux faire travailler plusieurs personnes sur un système de données global

1/ tu leur donnes des fichiers

2/ tu voudras ensuite récupérer leurs données je suppose

pour cela Excel n'est pas la solution

Excel ne doit pas être considéré comme un outil à tout faire, même par ceux qui le maîtrisent bien. Microsoft ne l'a pas conçu pour ça, et on va des déconvenues

passe à Access ou autre SGBD. Ils sont faits tout exprès pour ça.

mais ce n'est que mon conseil

Le 02/02/2018 à 14:23

Salut jmd,

Access etc. ce n'est pas une mauvaise idée du tout ! Seul hic, ils ne sont pas installer sur les postes de ma boite et en faire la demande débouchera sur un refus.... :-/

En fait je dispose déjà de toutes les données que je récupère automatiquement à droite à gauche de manière automatique.

Mon idée est vraiment de générer un reporting automatique par projet avec le moins de manip possible avec les moyens du bord, Excel encore et toujours donc

Peut-être qu'il faudrait que je me penche sur un ETL comme Pentaho par ex?

Le 02/02/2018 à 15:06

re

vois OOOBase pour leur permettre de saisir en multi-postes

ensuite il FAUT apprendre Power BI Desktop, gratuit, et plus facile que tous ses concurrents

le "meilleur" des ETL, même pour de gros volumes de données.

contient Power Query, tout comme Excel !

génial

Le 02/02/2018 à 15:11

Je vais explorer ces pistes.

en attendant je pense avoir presque trouvé en m'inspirant d'un code trouvé sur un autre fil du forum :

Sub Display_Projets()
Dim Cel As Range, Plg As Range
Dim DerLig As Long
Dim Sh As Worksheet, ShBase As Worksheet
Dim Projet As Object
Dim It
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
Set Projet = CreateObject("Scripting.Dictionary")
Set ShBase = Sheets("vue projet")
For Each Sh In Sheets
    If Sh.Name <> "vue projet" Then
        Sh.Delete
    End If
Next Sh
With ShBase
    .Range("T2").Value = .Range("C2").Value
    DerLig = .Cells(Rows.Count, "C").End(xlUp).Row
    Set Plg = .Range("C2:R" & DerLig)
    For Each Cel In .Range("C3:C" & DerLig)
        If Cel <> "" Then Projet(Cel.Value) = Cel.Value
    Next Cel
End With
For Each It In Projet.Items
    ShBase.Range("T3").Value = It
    Sheets.Add After:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = Replace(Left(It, 31), "/", "_")
        Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ShBase.Range("T2:T3"), CopyToRange:=.Range("A1")
        .Cells.WrapText = False
        .Columns.EntireColumn.AutoFit
    End With
Next It
With ShBase
    .Range("T2:T3").Clear
    .Select
End With
End Sub

Seul problème avec ça, je dois rater un truc bête mais il ne me copie pas la 1ère ligne... il scinde bien en plusieurs onglet mais la 1ère ligne de chaque onglet correspond à A2

Une idée ?

31projets.xlsm (457.21 Ko)
Le 02/02/2018 à 16:03

Bonjour,

tes fusions de cellules poseront toujours des problèmes mais ...

Tu peux modifier un peu ton code avec ceci:

Dim Titre

ShBase.Activate

Set Titre = Range("1:1")

With ActiveSheet

.Name = Replace(Left(It, 31), "/", "_")

Titre.Copy [A1] ' <------------------- ici

Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ShBase.Range("T2:T3"), CopyToRange:=.Range("A2") '<---- en 2e ligne

.Cells.WrapText = False

.Columns.EntireColumn.AutoFit

End With

P.

Le 05/02/2018 à 11:00

Merci Patrick1957 !

Désolé si ma question te semble stupide mais où dois-je insérer dans le code la partie ci-dessous :

Dim Titre

ShBase.Activate

Set Titre = Range("1:1")

?

(désolé moi grand débutant)

Merci

Le 05/02/2018 à 11:08

Bonjour,

les "dim" et autre "set" se mettent toujours en haut du code avec les autres

le reste, c'est le code que tu as posté entre le "with" et "end with"

P.

Le 05/02/2018 à 12:19

c'est bien ce que j'avais fait alors mais j'obtiens l'erreur d'exécution 91 :

variable ou object ou variable de bloc with non définie

--> ShBase.Activate apparait en jaune

On est plus de loin de la solution

ci-dessous le code actuel :

Sub Display_Projets()

Dim Cel As Range, Plg As Range

Dim DerLig As Long

Dim Sh As Worksheet, ShBase As Worksheet

Dim Titre

ShBase.Activate

Set Titre = Range("1:1")

Dim Projet As Object

Dim It

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

Set Projet = CreateObject("Scripting.Dictionary")

Set ShBase = Sheets("vue projet")

For Each Sh In Sheets

If Sh.Name <> "vue projet" Then

Sh.Delete

End If

Next Sh

With ShBase

.Range("T2").Value = .Range("C2").Value

DerLig = .Cells(Rows.Count, "C").End(xlUp).Row

Set Plg = .Range("C2:R" & DerLig)

For Each Cel In .Range("C3:C" & DerLig)

If Cel <> "" Then Projet(Cel.Value) = Cel.Value

Next Cel

End With

For Each It In Projet.Items

ShBase.Range("T3").Value = It

Sheets.Add After:=Sheets(Sheets.Count)

With ActiveSheet

.Name = Replace(Left(It, 31), "/", "_")

Titre.Copy [A1]

Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ShBase.Range("T2:T3"), CopyToRange:=.Range("A2")

.Cells.WrapText = False

.Columns.EntireColumn.AutoFit

End With

Next It

With ShBase

.Range("T2:T3").Clear

.Select

End With

Call Splitbook

End Sub

Le 05/02/2018 à 12:48

re,

ShBase.Activate ' pas encore connu, ça doit donc être après le "SET"

Set Titre = Range("1:1")

Dim Projet As Object

Dim It

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

Set Projet = CreateObject("Scripting.Dictionary")

Set ShBase = Sheets("vue projet")

ShBase.Activate

P.

Le 05/02/2018 à 13:15

ahah effectivement c'était tout bête... merci encore, ça marche parfaitement maintenant

Pour ceux qui serait intéressés voici le code final :

Sub Display_Projets()

Dim Cel As Range, Plg As Range

Dim DerLig As Long

Dim Sh As Worksheet, ShBase As Worksheet

Dim Titre

Set Titre = Range("1:1")

Dim Projet As Object

Dim It

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

Set Projet = CreateObject("Scripting.Dictionary")

Set ShBase = Sheets("vue projet")

ShBase.Activate

For Each Sh In Sheets

If Sh.Name <> "vue projet" Then

Sh.Delete

End If

Next Sh

With ShBase

.Range("T2").Value = .Range("C2").Value

DerLig = .Cells(Rows.Count, "C").End(xlUp).Row

Set Plg = .Range("A2:R" & DerLig)

For Each Cel In .Range("C3:C" & DerLig)

If Cel <> "" Then Projet(Cel.Value) = Cel.Value

Next Cel

End With

For Each It In Projet.Items

ShBase.Range("T3").Value = It

Sheets.Add after:=Sheets(Sheets.Count)

With ActiveSheet

.Name = Replace(Left(It, 31), "/", "_")

Titre.Copy [a1]

Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ShBase.Range("T2:T3"), CopyToRange:=.Range("A2")

.Cells.WrapText = False

.Columns.EntireColumn.AutoFit

End With

Next It

With ShBase

.Range("T2:T3").Clear

.Select

End With

Call Splitbook

End Sub

où le Call Splitbook (pour éclater les onglets en plusieurs feuilles) renvoit à ce code :

Sub Splitbook()

'Updateby20140612

Dim xPath As String

xPath = Application.ActiveWorkbook.Path

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each xWs In ThisWorkbook.Sheets

xWs.Copy

Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"

Application.ActiveWorkbook.Close False

Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

A la prochaine !

Alex

Rechercher des sujets similaires à "scinder tableau classeur criteres gardant mise"