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

[nat54]

Bonjour,

Pas simple de trouver un titre explicite 😀

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

 

[nat54]

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

j'avais déjà remarqué cela l'autre fois
cela est sûrement dû à l'export BO
mais je ne sais pas comment résoudre ce pb

si encore ca passait en fond noir mais là rouge c'est horrible 😱

 

[nat54]

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

on laisse tomber le pb du rouge

par contre j'ai voulu rajouter un fichier dans la boucle (j'avais réussi pour le 3èm ) mais là ca ne fonctionne pas

quelqu'un pour m'aider ?

 

[nat54]

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

limité à 4 fichiers

donc le fichier avec le VBA

 

[mromain]

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

bonjour nat54,

voici le code modifié :

Sub Creer_un_fichier_par_pole()
Dim fnRCinf35 As String, fnRCsup100 As String, fnBAR As String, fnPARAM_BAR As String, wbkRCinf35 As Workbook, wbkRCsup100 As Workbook, wbkBAR As Workbook, wbkPARAM_BAR As Workbook, newWbk As Workbook, extractFolderPath As String, shtRCinf35 As Worksheet, shtRCsup100 As Worksheet, shtBAR As Worksheet, shtPARAM_BAR As Worksheet, CodePole As String
Application.DisplayAlerts = False

'récupérer les "fichier sources" et le "dossier destination"
fnRCinf35 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_RCinf35_par_pole""")
fnBAR = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_BAR_par_pole""")
fnPARAM_BAR = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-PARAM-BAR_par_pole""")
fnRCsup100 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier ""PB-AGENTS_RCsup100_par_pole""")
extractFolderPath = "E:\aMiki\XLS\test\result"

'ouvrir les "fichier sources"
Set wbkRCinf35 = Application.Workbooks.Open(Filename:=fnRCinf35, ReadOnly:=True)
Set wbkBAR = Application.Workbooks.Open(Filename:=fnBAR, ReadOnly:=True)
Set wbkPARAM_BAR = Application.Workbooks.Open(Filename:=fnPARAM_BAR, ReadOnly:=True)
Set wbkRCsup100 = Application.Workbooks.Open(Filename:=fnRCsup100, ReadOnly:=True)

'boucler sur les onglets du fichier RC
For Each shtRCinf35 In wbkRCinf35.Sheets
    
    'récupérer le code pole de l'"onglet RC" analysé
    CodePole = Replace(shtRCinf35.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
    shtRCinf35.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    
    'supprimer toutes les autres feuilles
    While newWbk.Sheets.Count > 1
        newWbk.Sheets(1).Delete
    Wend
    newWbk.Sheets(newWbk.Sheets.Count).Name = newWbk.Sheets(newWbk.Sheets.Count).Name & "inf35"
    
    'boucler sur les onglets du fichier BAR (=99)
    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
    
    'boucler sur les onglets du fichier PARAM-BAR
    For Each shtPARAM_BAR In wbkPARAM_BAR.Sheets
        'si le nom de l'"onglet BAR" analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(shtPARAM_BAR.Name, CodePole) > 0 Then shtPARAM_BAR.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next shtPARAM_BAR

 'boucler sur les onglets du fichier RC > 100
    For Each shtRCsup100 In wbkRCsup100.Sheets
        'si le nom de l'"onglet RCsup100" analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(shtRCsup100.Name, CodePole) > 0 Then shtRCsup100.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next shtRCsup100

    'sauvegarder et fermer le classeur spécifique à ce pole
    newWbk.SaveAs extractFolderPath & "\ANOMALIES_" & CodePole
    newWbk.Close

Next shtRCinf35

'fermer les classeurs
wbkRCinf35.Close: Set wbkRCinf35 = Nothing
wbkBAR.Close: Set wbkBAR = Nothing
wbkPARAM_BAR.Close: Set wbkPARAM_BAR = Nothing
wbkRCsup100.Close: Set wbkRCinf35 = Nothing
Set newWbk = Nothing

Application.DisplayAlerts = True
End Sub

a+

 

[nat54]

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

où était l'erreur ? j'aime bien comprendre

je vais tester

 

[nat54]

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

J’ai vu
En fait j’avais 2 fois le même nom d’onglet*donc tu as rajouté & "inf35"

 

[mromain]

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

re,

exact, il y avait le PB du nom d'onglet, ainsi qu'un petit soucis de copier-coller ici :

Set wbkRCsup100 = Application.Workbooks.Open(Filename:=[B][COLOR=Red]fnRCinf35[/COLOR][/B], ReadOnly:=True)

a+

 

[nat54]

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

en tout cas, merci de ta super réactivité !