Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

A

aldo

XLDnaute Nouveau
Bonjour à toutes et tous, forum,

j'aimerai assez pouvoir ventiler automatiquement un fichier composé de 3 onglets en fonction des diffférentes premières lettres d'une colonne (la même dans les différents onglets.

J'ai cherché ici mais je n'ai pas trouvé mon bonheur (ou alors je ne l'ai pas compris...)

je dois faire cette opération au moins une fois par semaine et le fichier est assez important:
colonnes de A à BA
onglet 1 : environ 9000 lignes
onglet 2 : environ 4000 lignes
onglet 3 : environ 10000 lignes

le but étant de respecter la composition avec les 3 onglets pour chaque fichier créé suivant la première lettres de la colonne G.
Cette colonne est composée de noms de départements qui peuvent être de 1 à 7 ou 8 lettres plus des chiffres et des ? et des / et des -... il y a de tout en fait. c'est pour ça que je ne me préoccupe que de la première lettre (pour l'instant j'ai 15 premières lettres différentes.

est-ce que je suis assez clair ?

Je joins un exemple (Copy.xls) avec des données factices pour illustrer mon propos :
il y a trois onglets : R, D et C
et un autre fichier (but-Y.xls) avec le but à atteindre (ici, l'exemple de tout ce qui commence par "Y" dans la colonne G)

merci de m'avoir lu et d'essayer de m'aider.

Bonne journée.
 

Pièces jointes

  • but-Y.xls
    17 KB · Affichages: 74
  • Copy.xls
    27 KB · Affichages: 76
Trier par date Trier par votes
mromain

mromain

XLDnaute Barbatruc
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

bhbh à dit:
Re-,

@ mromain :):)

avec le fichier exemple d'aldo, ton code faisait 6 secondes, le mien un peu plus de 10...

Pour essais, j'ai créé un fichier avec les données d'aldo :



et j'ai déroulé nos 2 codes...

Le tien : 78 secondes
le mien : 12 secondes

Comme quoi le filtre élaboré reste quand même le plus rapide...

Amicalement
Cliquez pour agrandir...

ça fait plusieurs fois que je le remarque...
va falloir que je m'y mette ;)

a+
 
Vote positif 0 Vote négatif
A

aldo

XLDnaute Nouveau
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

Re,

@ bhbh : désolé mais c'est dans l'autre sens. j'ai donc eu la création de 250 et quelques fichiers et mon explorer a rendu l'âme !:D

@ mromain : merci beaucoup, ça marche impec', je vais voir pour aller jusqu'à trois lettres pour deux des fichiers générés à une lettre (vous me suivez?)
ça va me faire gagner un temps fou !

merci encore !

aldo
 
Vote positif 0 Vote négatif
A

aldo

XLDnaute Nouveau
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

eheh...
en fait, une fois utilisé ton code a généré plusieurs fichiers.
pour deux d'entres eux, E.xls et T.xls pour ne pas les nommer, je vais voir comment faire pour générer d'autres fichiers à 3 lettres : EEA, EEb, EEc, etc... et pareil pour T : TTA, TTB, etc...

est-ce plus clair?

aldo
 
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

Re-,

euh :

désolé mais c'est dans l'autre sens. j'ai donc eu la création de 250 et quelques fichiers
Cliquez pour agrandir...

avec le fichier que j'ai joint, j'ai la création de 10 fichiers....

Tu confirmes (avec mon fichier)?

J'ai le même nombre de fichiers générés que mromain :confused::confused:

Maintenant, si tu ne veux que les 3 premières lettres, on peut voir (PS, risques-tu d'avoir des "/" dans les 3 premières lettres?)
 
Vote positif 0 Vote négatif
A

aldo

XLDnaute Nouveau
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

voui, c'est exactement ce que j'ai essayé après m'être rappelé le post #13.. je ne sais pas si c'est à cause du numéro de post mais j'ai eu une erreur 1004...

je pense que c'est à cause du nom de mes départements :
ils sont tous "propres" sur la première lettres mais souvent la deuxième est un "?" ou un "/" et ça doit pas plaire à Excel...

me trompe-je ?

aldo
 
Vote positif 0 Vote négatif
A

aldo

XLDnaute Nouveau
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

@ bhbh :eek:ui j'ai utilisé ce code :

Code: 
Sub Eclate()
Dim DepT As Object
Dim Cel As Range
Dim Sh As Worksheet
Dim LePath As String, Nom As String
Dim DerLig As Long
Dim Interdits
Dim ThisW As Workbook
Dim Temp, NomsFeuilles, NF
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
Set ThisW = ThisWorkbook
LePath = ActiveWorkbook.Path & "\"
Set DepT = CreateObject("Scripting.Dictionary")
For Each Sh In ThisW.Sheets
    With Sh
        DerLig = .[A65000].End(xlUp).Row
        For Each Cel In .Range("G2:G" & DerLig)
            DepT.Item(Cel.Value) = Cel.Value
        Next Cel
    End With
Next Sh
Temp = Application.Transpose(DepT.Items)
Interdits = Array("[", "]", "/", "\", ":", "*", "?", "'")
NomsFeuilles = Array("RELEASED", "DRAFT", "CLOSED")
For i = LBound(Temp) To UBound(Temp)
    Workbooks.Add
    For Each NF In NomsFeuilles
        Sheets.Add.Name = NF
    Next NF
    Sheets("Sheet1").Delete
    Nom = Temp(i, 1)
    For j = 0 To UBound(Interdits) - 1
        Nom = Application.Substitute(Nom, Interdits(j), "_")
    Next j
    ActiveWorkbook.SaveAs LePath & Nom & ".xls"
Next i
For Each Sh In ThisW.Sheets
    With Sh
        DerLig = .[A65000].End(xlUp).Row
        .Range("A1:BA" & DerLig).Name = "base"
        .[BH1] = .[G1]
        .Range("G1:G" & DerLig).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range( _
            "BH1"), Unique:=True
        For Each Cel In .Range("BH2:BH" & .[BH65000].End(xlUp).Row)
            .[BH2] = Cel.Value
            Nom = Cel.Value
            For j = 0 To UBound(Interdits) - 1
                Nom = Application.Substitute(Nom, Interdits(j), "_")
            Next j
            Set Fdest = Workbooks(Nom & ".xls").Sheets(.Name)
            .Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("BH1:BH2"), _
                CopyToRange:=Fdest.Range("A1"), Unique:=False
        Next Cel
        .Columns(60).Clear
    End With
Next Sh
For i = LBound(Temp) To UBound(Temp)
    Nom = Temp(i, 1)
    For j = 0 To UBound(Interdits) - 1
        Nom = Application.Substitute(Nom, Interdits(j), "_")
    Next j
    Workbooks(Nom & ".xls").Close True
Next i
Application.DisplayAlerts = True
End Sub

j'ai juste modifié "Feuill1" par "Sheet1"
est-ce que je me suis trompé?

aldo
 
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

Re-,

non, si tu as Excel en Anglais, c'est normal..
Le nombre de fichiers générés correspond au nombre de départements...

version 4 avec uniquement les 3 premières lettres...
 

Pièces jointes

  • aldo_v4.zip
    18.8 KB · Affichages: 24
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

re,

essaye avec ce code :
Code: 
Public Sub test()
Application.ScreenUpdating = False
Dim listeDepartement() As String, i As Integer, j As Integer, wbk As Workbook, curSheet As Worksheet
[COLOR=Red][B]Dim Interdits, nomFichier As String
Interdits = Array("[", "]", "/", "\", ":", "*", "?", "'")[/B][/COLOR]
listeDepartement = RecupListeDepartements
For i = LBound(listeDepartement) To UBound(listeDepartement)
    Set wbk = Application.Workbooks.Add(xlWBATWorksheet)
    For Each curSheet In ThisWorkbook.Worksheets
        wbk.Sheets.Add after:=wbk.Sheets(wbk.Sheets.Count)
        With wbk.Sheets(wbk.Sheets.Count)
            .Name = curSheet.Name
            curSheet.Rows(1).Copy .Range("A1")
            For j = 2 To curSheet.Range("G" & curSheet.Rows.Count).End(xlUp).Row
                If curSheet.Range("G" & j).Text Like listeDepartement(i) & "*" Then
                    curSheet.Rows(j).Copy .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
                End If
            Next j
        End With
    Next curSheet
    Application.DisplayAlerts = False: wbk.Sheets(1).Delete: Application.DisplayAlerts = True
[COLOR=Red][B]    nomFichier = listeDepartement(i)
    For j = LBound(Interdits) To UBound(Interdits)
        nomFichier = Replace(nomFichier, Interdits(j), "_")
    Next j[/B][/COLOR]
    wbk.SaveAs (ThisWorkbook.Path & "\" & [B][COLOR=Red]nomFichier[/COLOR][/B])
    wbk.Close False
Next i
Application.ScreenUpdating = True
End Sub


Private Function RecupListeDepartements() As String()
Dim curSheet As Worksheet, tableauDepartements() As String, i As Integer, compteurTableau As Integer
ReDim tableauDepartements(1 To 1)
For Each curSheet In ThisWorkbook.Worksheets
    For i = 2 To curSheet.Range("G" & curSheet.Rows.Count).End(xlUp).Row
        If Not verifDejaSaisi(tableauDepartements, Left(curSheet.Range("G" & i).Text, 1)) Then
            compteurTableau = compteurTableau + 1
            ReDim Preserve tableauDepartements(1 To compteurTableau)
            tableauDepartements(UBound(tableauDepartements)) = Left(curSheet.Range("G" & i).Text, 1)
        End If
    Next i
Next curSheet
RecupListeDepartements = tableauDepartements
End Function

Private Function verifDejaSaisi(tableau() As String, valeur As String) As Boolean
Dim i As Integer
verifDejaSaisi = False
For i = LBound(tableau) To UBound(tableau)
    If tableau(i) = valeur Then verifDejaSaisi = True: Exit Function
Next i
End Function

a+
 
Vote positif 0 Vote négatif
A

aldo

XLDnaute Nouveau
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

@ mromain :

euh... j'ai toujours une erreur à la fin quand la macro essaie d'enregistrer le fichier E-.xls, excel me dit que le fichier existe déjà...

Run-Time error '1004':
Method 'SavedAs' of object"_Workbook' failed
debugger sur la ligne

wbk.SaveAs (ThisWorkbook.Path & "\" & nomFichier)

le problème vient des "?" je pense.
il faut que je nettoie mon fichier.... encore...

aldo
 
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

re,


encore (et toujours ;)) un autre essai :
Code: 
Public Sub test()
Application.ScreenUpdating = False
Dim listeDepartement() As String, i As Integer, j As Integer, wbk As Workbook, curSheet As Worksheet
Dim Interdits, nomFichier As String[COLOR=Red][B], compt As Integer[/B][/COLOR]
Interdits = Array("[", "]", "/", "\", ":", "*", "?", "'")
listeDepartement = RecupListeDepartements
For i = LBound(listeDepartement) To UBound(listeDepartement)
    Set wbk = Application.Workbooks.Add(xlWBATWorksheet)
    For Each curSheet In ThisWorkbook.Worksheets
        wbk.Sheets.Add after:=wbk.Sheets(wbk.Sheets.Count)
        With wbk.Sheets(wbk.Sheets.Count)
            .Name = curSheet.Name
            curSheet.Rows(1).Copy .Range("A1")
            For j = 2 To curSheet.Range("G" & curSheet.Rows.Count).End(xlUp).Row
                If curSheet.Range("G" & j).Text Like listeDepartement(i) & "*" Then
                    curSheet.Rows(j).Copy .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
                End If
            Next j
        End With
    Next curSheet
    Application.DisplayAlerts = False: wbk.Sheets(1).Delete: Application.DisplayAlerts = True
    nomFichier = listeDepartement(i)
    For j = LBound(Interdits) To UBound(Interdits)
        nomFichier = Replace(nomFichier, Interdits(j), "_")
    Next j
[COLOR=Red][B]    If Dir(ThisWorkbook.Path & "\" & nomFichier & ".xls") <> vbNullString Then
        compt = 0
        While Dir(ThisWorkbook.Path & "\" & nomFichier & CStr(compt) & ".xls") <> vbNullString
            compt = compt + 1
        Wend
        nomFichier = nomFichier & CStr(compt)
    End If
[/B][/COLOR]    wbk.SaveAs (ThisWorkbook.Path & "\" & nomFichier)
    wbk.Close False
Next i
Application.ScreenUpdating = True
End Sub


Private Function RecupListeDepartements() As String()
Dim curSheet As Worksheet, tableauDepartements() As String, i As Integer, compteurTableau As Integer
ReDim tableauDepartements(1 To 1)
For Each curSheet In ThisWorkbook.Worksheets
    For i = 2 To curSheet.Range("G" & curSheet.Rows.Count).End(xlUp).Row
        If Not verifDejaSaisi(tableauDepartements, Left(curSheet.Range("G" & i).Text, 1)) Then
            compteurTableau = compteurTableau + 1
            ReDim Preserve tableauDepartements(1 To compteurTableau)
            tableauDepartements(UBound(tableauDepartements)) = Left(curSheet.Range("G" & i).Text, 1)
        End If
    Next i
Next curSheet
RecupListeDepartements = tableauDepartements
End Function

Private Function verifDejaSaisi(tableau() As String, valeur As String) As Boolean
Dim i As Integer
verifDejaSaisi = False
For i = LBound(tableau) To UBound(tableau)
    If tableau(i) = valeur Then verifDejaSaisi = True: Exit Function
Next i
End Function
a+
 
Vote positif 0 Vote négatif
A

aldo

XLDnaute Nouveau
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

euh...
bah là il m'a généré un fichier (un seul) avec tout dedans...
ais je pense avoir une piste, j'ai classé mon fichier sur la colonne G et en fait il bug au moment où il rencontre une cellule dans laquelle il n'y a que "E"

ça vous parle?

pour être plus précis : dans la colonne G, il peut y avoir :
E
Exxxxxxx
E?
E?xxxxxxx
E?/xxxxxxx

où "x" peut être une(des) autre(s) lettre(s) ou un chiffre ou un "_" ou un "-"

aldo
 
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

Bon,

moi, j'arrête...

c'est plus un fil, c'est une pelote...

Tu ne nous donnes pas toutes les infos, dès le début, et au fur et à mesure des bugs, tu nous en dis plus...

Pas envie de jouer au chat et à la souris...

Bye
 
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : Ventiler 3 onglets en X fois 3 onglets suivant 1ère lettre d'une colonne

re,

encore un essai :
Code: 
Public Sub test()
Application.ScreenUpdating = False
Dim listeDepartement() As String, i As Integer, j As Integer, wbk As Workbook, curSheet As Worksheet
Dim Interdits, nomFichier As String, compt As Integer
Interdits = Array("[", "]", "/", "\", ":", "*", "?", "'")
listeDepartement = RecupListeDepartements
For i = LBound(listeDepartement) To UBound(listeDepartement)
    Set wbk = Application.Workbooks.Add(xlWBATWorksheet)
    For Each curSheet In ThisWorkbook.Worksheets
        wbk.Sheets.Add after:=wbk.Sheets(wbk.Sheets.Count)
        With wbk.Sheets(wbk.Sheets.Count)
            .Name = curSheet.Name
            curSheet.Rows(1).Copy .Range("A1")
            For j = 2 To curSheet.Range("G" & curSheet.Rows.Count).End(xlUp).Row
                If curSheet.Range("G" & j).Text Like listeDepartement(i) & "*" Then
                    curSheet.Rows(j).Copy .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
                End If
            Next j
        End With
    Next curSheet
    Application.DisplayAlerts = False: wbk.Sheets(1).Delete: Application.DisplayAlerts = True
    nomFichier = listeDepartement(i)
    For j = LBound(Interdits) To UBound(Interdits)
        nomFichier = Replace(nomFichier, Interdits(j), "_")
    Next j
    If Dir(ThisWorkbook.Path & "\" & nomFichier & ".xls") <> vbNullString Then
        compt = 0
        While Dir(ThisWorkbook.Path & "\" & nomFichier & CStr(compt) & ".xls") <> vbNullString
            compt = compt + 1
        Wend
        nomFichier = nomFichier & CStr(compt)
    End If
    wbk.SaveAs (ThisWorkbook.Path & "\" & nomFichier)
    wbk.Close False
Next i
Application.ScreenUpdating = True
End Sub


Private Function RecupListeDepartements() As String()
Dim curSheet As Worksheet, tableauDepartements() As String, i As Integer, compteurTableau As Integer, val As String
ReDim tableauDepartements(1 To 1)
For Each curSheet In ThisWorkbook.Worksheets
    For i = 2 To curSheet.Range("G" & curSheet.Rows.Count).End(xlUp).Row
        val = curSheet.Range("G" & i).Text
        On Error Resume Next
        val = Left(val, 1)
        On Error GoTo 0
        If Not verifDejaSaisi(tableauDepartements, val) Then
            compteurTableau = compteurTableau + 1
            ReDim Preserve tableauDepartements(1 To compteurTableau)
            tableauDepartements(UBound(tableauDepartements)) = val
        End If
    Next i
Next curSheet
RecupListeDepartements = tableauDepartements
End Function

Private Function verifDejaSaisi(tableau() As String, valeur As String) As Boolean
Dim i As Integer
verifDejaSaisi = False
For i = LBound(tableau) To UBound(tableau)
    If tableau(i) = valeur Then verifDejaSaisi = True: Exit Function
Next i
End Function

a+
 
Vote positif 0 Vote négatif

Discussions similaires

V
  • Question
XL 2021 avoir des données dans plusieurs onglets en fonction de plusieurs conditions
Réponses
5
Affichages
248
mapomme
mapomme
R
  • Résolu(e)
Autres Masquer des lignes et colonnes en fonction d'une valeur d'un menu déroulant
Réponses
1
Affichages
187
Romain77144
R
L
  • Résolu(e)
Microsoft 365 VBA - Attribuer mise en forme en fonction de valeur cellule d'une liste
Réponses
14
Affichages
485
Laliepomm
L
S
  • Résolu(e)
Microsoft 365 vba, récupérer le résultat d'un INDEX(EQUIV en fonction du résultat
Réponses
6
Affichages
213
SOP
S
C
  • Question
XL 2016 rapatrier des informations en "scannant" les onglets d'un fichier excel vers les cellules d'un autre onglet
Réponses
6
Affichages
575
job75
job75
A
  • Résolu(e)
Microsoft 365 Nommer des feuilles en fonction des données d'une colonne
Réponses
9
Affichages
340
AD95
A
S
  • Question
XL 2016 Bloquer la MaJ des formules de certains onglets
Réponses
2
Affichages
301
Hasco
Hasco
A
  • Question
Microsoft 365 Afficher la valeur d'une cellule en fonction de 3 conditions via VBA
Réponses
2
Affichages
425
Ay-Ricko
A
B
  • Question
XL 2016 Macro BVA pour créer une synthèse à partir de plusieurs onglets Excel
Réponses
6
Affichages
650
bnolwalid
B
A
  • Question
Microsoft 365 Copie VBA d'un tableau présent et identique sur 12 onglets dans un autre onglet dont seules les lignes complétées sont copiées
Réponses
4
Affichages
478
AlexiaC
A

Membres actuellement en ligne

21 membres et 423 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 721
Messages
2 091 341
Membres
104 881
dernier inscrit
Serigne Mbacké Seye