VBA - Regrouper des onglets ayant des caractères communs en un fichier

nat54

nat54

XLDnaute Barbatruc
Bonjour,

Pas simple de trouver un titre explicite :D

Contexte : 2 fichiers de chacun 31 onglets
- fichier PB-AGENTS_RC : 31 onglets tous nommés de la même façon : PB_RC_1234, PB_RC_4567 …
- fichier PB-AGENTS_BAR : 31 onglets tous nommés de la même façon : BAR=99 (1234), BAR=99 (4567)…

Objectif
Obtenir un fichier par pôle (1er pôle = 1234, 2èm pole = 4567 …)contenant 2 onglets

Exemple
Fichier ANOMALIES_1234 :
un onglet PB_RC_1234,
un onglet BAR=99 (1234)

Je ne sais pas du tout comment retrouver un bout du nom de l'onglet pour faire la correspondance

Merci d'avance !

Nat
 
Trier par date Trier par votes
pierrejean

pierrejean

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

bonjour Nat

pour t'aider:

Code: 
'commun du nom d'onglet dans fichier PB - AGENTS_RC:
comPB_RC = Replace(sh.Name, "PB_RC_", "")
'commun du nom d'onglet dans fichier BAR ...:
comBAR = Replace(sh.Name, "BAR=99 ", "")
comBAR = Mid(comBAR, 2, Len(comBAR) - 1)

Si pas suffisant n'hesite pas a revenir
 
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

bonjour nat54, pierrejean,

voici une macro qui a l'air de répondre à ta demande :
Code: 
[COLOR=Blue]Sub[/COLOR] test()
[COLOR=Blue]Dim [/COLOR]fnRC [COLOR=Blue]As String[/COLOR], fnBAR [COLOR=Blue]As String[/COLOR], wbkRC [COLOR=Blue]As [/COLOR]Workbook, wbkBAR [COLOR=Blue]As [/COLOR]Workbook, newWbk [COLOR=Blue]As [/COLOR]Workbook, extractFolderPath [COLOR=Blue]As String[/COLOR], shtRC [COLOR=Blue]As [/COLOR]Worksheet, shtBAR [COLOR=Blue]As [/COLOR]Worksheet, errorCode [COLOR=Blue]As String[/COLOR]
Application.DisplayAlerts = [COLOR=Blue]False[/COLOR]

[COLOR=SeaGreen]'récupérer les "fichier sources" et le "dossier destination"[/COLOR]
fnRC = Application.GetSaveAsFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_RC""")
fnBAR = Application.GetSaveAsFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_BAR""")
Application.FileDialog(msoFileDialogFolderPicker).Show
extractFolderPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
[COLOR=SeaGreen]
'ouvrir les "fichier sources"[/COLOR]
[COLOR=Blue]Set [/COLOR]wbkRC = Application.Workbooks.Open(Filename:=fnRC, ReadOnly:=[COLOR=Blue]True[/COLOR])
[COLOR=Blue]Set [/COLOR]wbkBAR = Application.Workbooks.Open(Filename:=fnBAR, ReadOnly:=[COLOR=Blue]True[/COLOR])

[COLOR=SeaGreen]'boucler sur les onglets du fichie RC[/COLOR]
[COLOR=Blue]For Each[/COLOR] shtRC [COLOR=Blue]In [/COLOR]wbkRC.Sheets
    
    [COLOR=SeaGreen]'récupérer le code erreur de l'"onglet RC" analysé[/COLOR]
    errorCode = Replace(shtRC.Name, "PB_RC_", "")
    
   [COLOR=SeaGreen] 'créer le classeur spécifique à cette erreur[/COLOR]
    [COLOR=Blue]Set [/COLOR]newWbk = Application.Workbooks.Add
    
    [COLOR=SeaGreen]'copier l'"onglet RC" analysé après le dernier onglet du nouveau classeur[/COLOR]
    shtRC.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    
    [COLOR=SeaGreen]'supprimer toutes les autres feuilles[/COLOR]
    [COLOR=Blue]While [/COLOR]newWbk.Sheets.Count > 1
        newWbk.Sheets(1).Delete
    [COLOR=Blue]Wend[/COLOR]
    
    [COLOR=SeaGreen]'boucler sur les onglets du fichie BAR[/COLOR]
    [COLOR=Blue]For Each[/COLOR] shtBAR [COLOR=Blue]In [/COLOR]wbkBAR.Sheets
        [COLOR=SeaGreen]'si le nom de l'"onglet BAR" analysé contien le "code erreur", alors on copie la feuille dans le nouveau classeur[/COLOR]
        [COLOR=Blue]If [/COLOR]InStr(shtBAR.Name, errorCode) > 0 [COLOR=Blue]Then [/COLOR]shtBAR.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    [COLOR=Blue]Next [/COLOR]shtBAR
    
   [COLOR=SeaGreen] 'sauvegarder et fermer le classeur spécifique à cette erreur[/COLOR]
    newWbk.SaveAs extractFolderPath & "\ANOMALIES_" & errorCode
    newWbk.Close

[COLOR=Blue]Next [/COLOR]shtRC

[COLOR=SeaGreen]'fermer les classeurs[/COLOR]
wbkRC.Close: [COLOR=Blue]Set [/COLOR]wbkRC = Nothing
wbkBAR.Close: [COLOR=Blue]Set [/COLOR]wbkBAR = Nothing
Set newWbk = Nothing

Application.DisplayAlerts = [COLOR=Blue]True[/COLOR]
[COLOR=Blue]End Sub[/COLOR]
a+
 
Dernière édition:
Vote positif 0 Vote négatif
nat54

nat54

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

Bonjour,

Merci Romain

Cependant,

Application.FileDialog(msoFileDialogFolderPicker).Show
> propriété ou méthode non gérée par cet objet >> débogage

Faut-il changer un paramètre dans excel.. ?
 
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

bonjour nat54,

je ne sais pas trop... ça fonctionne sur ma version d'Excel (2007).

au pire, tu replace
Code: 
Application.FileDialog(msoFileDialogFolderPicker).Show
extractFolderPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
par un chemin en dur
Code: 
extractFolderPath = "C:\tmp\testExcel"

a+
 
Vote positif 0 Vote négatif
nat54

nat54

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

Code: 
Sub Creer_les_fichiers_par_pole()
Dim fnRC As String, fnBAR As String, wbkRC As Workbook, wbkBAR As Workbook, newWbk As Workbook, extractFolderPath As String, shtRC As Worksheet, shtBAR As Worksheet, CodePole As String
Application.DisplayAlerts = False
'récupérer les "fichier sources" et le "dossier destination"
fnRC = Application.GetSaveAsFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_RC_par_pole""")
fnBAR = Application.GetSaveAsFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_BAR_par_pole""")
extractFolderPath = "I:\DRH\EFFECTIF\BO\Gestor\test_03-09_par_pole"
'ouvrir les "fichier sources"
Set wbkRC = Application.Workbooks.Open(Filename:=fnRC, ReadOnly:=True)
Set wbkBAR = Application.Workbooks.Open(Filename:=fnBAR, ReadOnly:=True)
'boucler sur les onglets du fichier RC
For Each shtRC In wbkRC.Sheets
    
    'récupérer le code pole de l'"onglet RC" analysé
    CodePole = Replace(shtRC.Name, "PB_RC_", "")
    
    'créer le classeur spécifique à ce pole
    Set newWbk = Application.Workbooks.Add
    
    'copier l'"onglet RC" analysé après le dernier onglet du nouveau classeur
    shtRC.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    
    'supprimer toutes les autres feuilles
    While newWbk.Sheets.Count > 1
        newWbk.Sheets(1).Delete
    Wend
    
    'boucler sur les onglets du fichier BAR
    For Each shtBAR In wbkBAR.Sheets
        'si le nom de l'"onglet BAR" analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(shtBAR.Name, CodePole) > 0 Then shtBAR.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next shtBAR
    
    'sauvegarder et fermer le classeur spécifique à ce pole
    newWbk.SaveAs extractFolderPath & "\ANOMALIES_" & CodePole
    newWbk.Close
Next shtRC
'fermer les classeurs
wbkRC.Close: Set wbkRC = Nothing
wbkBAR.Close: Set wbkBAR = Nothing
Set newWbk = Nothing
Application.DisplayAlerts = True
End Sub

alors ça ne bloque effectivement plus à la ligne évoquée

je lance

ca me crée bien 31 fichiers
MAIS juste avec mes anomalies RC (un seul onglet),
les anomalies BAR n'apparaissent pas

je mets 2 fichier test c'est peut-être plus simple pour toi
 

Pièces jointes

  • test_PB-AGENTS_BAR_par_pole.xls
    16.5 KB · Affichages: 78
  • test_PB-AGENTS_RC_par_pole.xls
    17 KB · Affichages: 81
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

re salut

il faut remplacer "PB_RC_" par "PB RC ".
voici le code modifié :

Code: 
Sub Creer_les_fichiers_par_pole()
Dim fnRC As String, fnBAR As String, wbkRC As Workbook, wbkBAR As Workbook, newWbk As Workbook, extractFolderPath As String, shtRC As Worksheet, shtBAR As Worksheet, CodePole As String
Application.DisplayAlerts = False
'récupérer les "fichier sources" et le "dossier destination"
fnRC = Application.GetSaveAsFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_RC_par_pole""")
fnBAR = Application.GetSaveAsFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_BAR_par_pole""")
extractFolderPath = "I:\DRH\EFFECTIF\BO\Gestor\test_03-09_par_pole"
'ouvrir les "fichier sources"
Set wbkRC = Application.Workbooks.Open(Filename:=fnRC, ReadOnly:=True)
Set wbkBAR = Application.Workbooks.Open(Filename:=fnBAR, ReadOnly:=True)
'boucler sur les onglets du fichier RC
For Each shtRC In wbkRC.Sheets
    
    'récupérer le code pole de l'"onglet RC" analysé
    CodePole = Replace(shtRC.Name, "[B][COLOR=Red]PB RC [/COLOR][/B]", "")
    
    'créer le classeur spécifique à ce pole
    Set newWbk = Application.Workbooks.Add
    
    'copier l'"onglet RC" analysé après le dernier onglet du nouveau classeur
    shtRC.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    
    'supprimer toutes les autres feuilles
    While newWbk.Sheets.Count > 1
        newWbk.Sheets(1).Delete
    Wend
    
    'boucler sur les onglets du fichier BAR
    For Each shtBAR In wbkBAR.Sheets
        'si le nom de l'"onglet BAR" analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(shtBAR.Name, CodePole) > 0 Then shtBAR.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next shtBAR
    
    'sauvegarder et fermer le classeur spécifique à ce pole
    newWbk.SaveAs extractFolderPath & "\ANOMALIES_" & CodePole
    newWbk.Close
Next shtRC
'fermer les classeurs
wbkRC.Close: Set wbkRC = Nothing
wbkBAR.Close: Set wbkBAR = Nothing
Set newWbk = Nothing
Application.DisplayAlerts = True
End Sub

a+
 
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

re salut,

voici ce que j'obtiens avec le code de ton dernier post (en modifiant juste le chemin du dossier)

Je les ai juste réenregistré en .xls (vu que je travaille avec 2007, il les enregistre en .xlsx par défaut).

a+


edit: j'avais pas rafraichi :)
 

Pièces jointes

  • ANOMALIES_3580.xls
    20 KB · Affichages: 84
  • ANOMALIES_3945.xls
    20.5 KB · Affichages: 80
Vote positif 0 Vote négatif
nat54

nat54

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

Grand merci j'ai rajouté la même chose sur mon 3èm fichier

je vais regarder un de tes fichiers voir par contre si la mise en forme change
titre fond gris dans fichiers source > titre sur fond rouge :confused:
(les fichiers source sont des export de BO)
 
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : VBA - Regrouper des onglets ayant des caractères communs en un fichier

salut,

c(est vrai que c'est bizarre ce changement de couleur de fond, je ne sais pas d'où ça peut venir...

j'ai essayé de copier une des "cellules-titres" de ton classeur test_PB-AGENTS_BAR_par_pole.xls (sur fond gris donc) et de la coller dans un nouveau classeur, et le fond change encore de couleur (il devient rouge).

étrange~~~

a+
 
Vote positif 0 Vote négatif

Discussions similaires

G
  • Question
Power Query Regrouper les donnees de differents onglets excel de differents fichiers dans un seul fichier excel
Réponses
8
Affichages
873
guazzini
G
Simbaa
  • Question
Microsoft 365 Création d'un fichier entier par rapport à des entrées via UserForm
Réponses
1
Affichages
369
job75
job75
M
  • Résolu(e)
XL 2013 actualiser le nom des onglets en automatique à l'ouverture du fichier et ou VBA
Réponses
3
Affichages
2 K
mrdo
M
don_pets
  • Question
XL 2013 Regrouper des Onglets pour créer un nouveau fichier
Réponses
3
Affichages
773
don_pets
don_pets
R
  • Question
XL 2016 Regroupement plusieurs onglets en un seul
Réponses
9
Affichages
1 K
kiki29
kiki29
T
  • Question
XL 2016 Récupérer des informations sous conditions - VBA
Réponses
4
Affichages
1 K
Tophe2
T
C
  • Résolu(e)
XL 2019 Synthétiser efficacement des données non contigues dans plusieurs onglets d'un classeur
Réponses
5
Affichages
1 K
CiolBel
C
M
  • Question
Créer un TCD en vba dont le fichier source de données est variable
Réponses
1
Affichages
3 K
chris
chris
B
  • Question
XL 2016 Récupération des données de plusieurs onglets en un seul
Réponses
6
Affichages
4 K
bnolwalid
B
A
  • Question
XL 2013 Macro enregistrer les onglets en .pdf avec nom des onglets + suffixe dans un dossier choisi
2
Réponses
19
Affichages
9 K
Staple1600
Staple1600

Membres actuellement en ligne

12 membres et 124 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 331
Messages
2 087 354
Membres
103 528
dernier inscrit
hplus