Regrouper des classeurs avec un onglet par classeur

Messages postés
511
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 décembre 2019
- - Dernière réponse : Mistral_13200
Messages postés
511
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 décembre 2019
- 18 nov. 2019 à 16:07
Bonjour à tous,

Je reviens vers vous, car j’ai encore besoin de vous.
Je voudrais regrouper tous les fichiers d’un répertoire dans un seul classeur avec un onglet par fichier copié. Chaque fichier ne possède qu’un seul onglet et cet onglet a le même nom dans tous les fichiers. Chaque fichier est nommé par un chiffre et quatre lettres (1_xxxx). J’ai cherché et j’ai trouvé la macro ci-dessous qui répond en partie à mes besoins.

Option Explicit

Public Sub regroupe()
Dim chemin As String ' classeur regroup?
Dim rep As String ' r?pertoire ? traiter
Dim fic As String ' classeur regroup?
Dim ligne As Long ' ligne ?criture
Dim nbc As Integer ' nombre de classeurs
Dim Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroup?e

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

rep = ThisWorkbook.Path & "\"

On Error GoTo fin

Set Wf = ThisWorkbook.ActiveSheet ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0 ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xlsx") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
chemin = rep & fic ' chemin fichiers
Workbooks.Open chemin, 0 ' ouverture
Set Wl = ActiveWorkbook.Sheets(1)
Wl.Copy After:=Wf
Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
fic = Dir
Wend

fin:
MsgBox nbc & " classeurs regroup?s"
Application.DisplayAlerts = True
End Sub



Elle copie bien chaque fichier sur des onglets différents, mais je me retrouve avec des onglets portant le même nom et un chiffre pour les distinguer (club(1), Club (2) …).
Je voudrais que chaque onglet prenne le nom du fichier original et que les onglets soient classés dans l’ordre décroissant de gauche à droite.
Merci d’avance pour votre aide.
Mistral
Afficher la suite 

7 réponses

Meilleure réponse
Messages postés
2025
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
24 novembre 2019
238
1
Merci
Bonjour,

Sub Tri_Par_Onglets()
    Application.ScreenUpdating = False
    For i = 1 To Sheets.Count
        For j = 1 To Sheets.Count
             If UCase(Sheets(i).Name) < UCase(Sheets(j).Name) Then Sheets(j).Move before:=Sheets(i)
        Next j
    Next i
End Sub


Cdlt

Dire « Merci » 1

Heureux de vous avoir aidé ! Vous nous appréciez ? Donnez votre avis sur nous ! Evaluez CommentCaMarche

CCM 65010 internautes nous ont dit merci ce mois-ci

Commenter la réponse de Frenchie83
Messages postés
2025
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
24 novembre 2019
238
1
Merci
Le tri qui est fait ressemble plus à un tri aléatoire, alors que j'ai besoin d'un tri décroissant.
Non, ce n'est pas un tri aléatoire, seulement s'il y a des valeurs supérieures à 10, excel fait un tri sur le premier chiffre de gauche.
Exemple dans le cas suivant
club(1), club(2),Club(11), club(21),
en tri décroissant cela donnera Club(21), Club(2), Club(11), Club(1).

Ne connaissant pas le nombre de feuilles dont vous disposez, j'ai opté pour la méthode la plus simple, s'il y a plus de 10 feuilles il faut que je revoie le raisonnement.

Sinon j'ai une autre solution pour ne pas refaire ce que j'ai fait: complétez les noms de feuilles avec des 0 non significatifs, club(1) devient Club(01), club(2) devient Club(02) et ainsi de suite, à partir de 10 on ne touche à rien. Avec cette méthode le tri se fera correctement.

Cdlt

Dire « Merci » 1

Heureux de vous avoir aidé ! Vous nous appréciez ? Donnez votre avis sur nous ! Evaluez CommentCaMarche

CCM 65010 internautes nous ont dit merci ce mois-ci

Commenter la réponse de Frenchie83
Messages postés
511
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 décembre 2019
3
0
Merci
Frenchie 83 merci pour ta réponse mais elle ne correspond pas à ma demande.
1) Elle ne répond qu'à une partie de mes besoins.
2) Le trie qui est fait ressemble plus à un tri aléatoire, alors que j'ai besoin d'un trie décroissant.

Encore une fois merci d'y avoir consacré du temps.

Mistral
Commenter la réponse de Mistral_13200
Messages postés
511
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 décembre 2019
3
0
Merci
Bonsoir à tous,

J’ai poursuivi mes recherches et j’ai trouvé la macro qui suit :

<code>Sub Fusionner_classeur()
'
Dim xStrPath As String ' Chemin du répertoire source
Dim xStrFName As String ' Nom du fichier source
Dim xWS As Worksheet
Dim xMWS As Worksheet ' Nom de l'onglet
Dim xTWB As Workbook
Dim xStrAWBName As String ' Nom du fichier cible

On Error Resume Next
' Bloque le rafraichissement et les alarmes.
Application.ScreenUpdating = False
Application.DisplayAlerts = False

xStrPath = "S:\_Fédération Photographique de France\_Annéeencours_FPF_ N&B\2020\N1\_Adresse club\"
xStrFName = Dir(xStrPath & "*.xlsx")

Set xTWB = ThisWorkbook
Do While Len(xStrFName) > 0
Workbooks.Open Filename:=xStrPath & xStrFName, ReadOnly:=True ' Ouverture du 1er fichier à copier
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets ' Copie le fichier source
xWS.Copy After:=xTWB.Sheets(xTWB.Sheets.Count) ' Colle du fichier dans le classeur cible
Set xMWS = xTWB.Sheets(xTWB.Sheets.Count)
xMWS.Name = xStrAWBName & "(" & xMWS.Name & ")" ' Renomme l'onglet créé dans le classeur cible
Next xWS
Workbooks(xStrAWBName).Close ' Fermeture du fichier copié
xStrFName = Dir() ' Sélectionne le fichier suivant
Loop

'Rétabli le rafraichissement et les alarmes
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub<code>

Elle me convient presque, je veux dire que je copie bien tous les fichiers du répertoire source sur un onglet du classeur cible. Cet onglet est renommé avec le nom et l’extension du fichier + le nom de l’onglet dans le classeur source.
Je voudrais que l’onglet créé prenne le nom du classeur source sans l’extension .Xlsx.
Je pense avoir compris cette macro, mais je bloque pour modifier ce nom.

Merci d’avance pour votre aide.
Mistral
Commenter la réponse de Mistral_13200
Messages postés
511
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 décembre 2019
3
0
Merci
Bonjour Frenchie,

Je ne pense pas avoir écrit que c'était un tri aléatoire et je suis d'accord avec vous quant à la méthode utilisée par Excel pour le tri.
Je peux avoir au maximum 50 fichiers dans le répertoire source. Chaque fichier n'a qu'un seul onglet. Tous les onglets ont le même nom. Les fichiers sont nommés comme suit : XX_YYYY ou XX prend une valeur entre 1 et 50 et ou YYYY prend une entre 1 et 9999. Le nom des fichier est donc : XX_YYYY.Xlsx
Ce que je souhaiterais c'est avoir dans le classeur cible un onglet par fichier et que chaque onglet prenne le nom du fichier sans l'extension (.Xlsx).
Ta dernière proposition, de renommer les fichiers avant n'est pas acceptable car trop longue et surtout répétitive tous les mois.

La macro que j'ai trouvé hier AM (voir plus haut) est presque bonne :
- Elle regroupe bien tous les fichiers avec un onglet par fichier.
- Elle renomme bien les onglets et je les ai dans l'ordre voulu.
Mais le nom qui est affecté aux onglets ne me convient pas. Ils sont renommés du nom du fichier d'origine avec l'extension plus le nom de l'onglet. Je voudrais que le nom de l'onglet soit XX.YYYY égal au nom du fichier d'origine sans l'extension (.Xlsx).

J'espère que ces précisions seront suffisantes.
En tout cas merci d'avance.
Mistral
Commenter la réponse de Mistral_13200
Messages postés
6409
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
2 décembre 2019
419
0
Merci
Bonjour,

en réponse à:

Je voudrais que le nom de l'onglet soit XX.YYYY égal au nom du fichier d'origine sans l'extension (.Xlsx).

avec la fonction Split

https://silkyroad.developpez.com/VBA/ManipulerChainesCaracteres/#LI-I

Dim nom As String
nom = Dir(chemin complet) 'nom avec extension
nom = Split(nom, ".")(0) 'nom sans extension (0) = chaine avant le séparateur (point)


Voilà

cs_Le Pivert
Messages postés
6409
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
2 décembre 2019
419 -
Voilà un exemple avec les classeurs fermés en utilisant ADO:

https://silkyroad.developpez.com/VBA/ClasseursFermes/

et pour trouver le nom de la feuille concernée:

https://silkyroad.developpez.com/VBA/ClasseursFermes/#LV

voici le code avec le classeur contenant les macros dans le même dossier:

Sub lister()
Dim monFichier As String
Dim wb As Workbook
Dim chemin As String
Set wb = Workbooks(ThisWorkbook.Name) 'classeur reception
' On a besoin du chemin absolu du dossier
' Doit se terminer par \
chemin = ThisWorkbook.Path & "\"
' La fonction Dir(chemin, mode) permet de parcourir un dossier
' Ici je rajoute à mon chemin "*.xlsx",
' pour ne retrouver que mes fichiers Excel
' vbNormal permet de ne récupérer que des fichiers,
' vbDirectory récupère tout (dossiers et fichiers)
monFichier = Dir(chemin & "*.xlsx", vbNormal)
Do While monFichier <> ""
   wb.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Split(monFichier, ".")(0) 'ajoute un onglet et le renomme
RequeteClasseurFerme (chemin & monFichier)
' Permet de passer au fichier suivant
monFichier = Dir
Loop
End Sub
'https://silkyroad.developpez.com/VBA/ClasseursFermes/
'https://silkyroad.developpez.com/VBA/ClasseursFermes/#LV
   'Nécéssite d'activer la référence Microsoft ADO ext x.x for DLL and Security
   'Vous devez préalablement activer la référence Microsoft ActiveX Data Objects x.x Library pour utiliser les exemples présentés dans ce tutoriel.
  Sub RequeteClasseurFerme(ByVal chemin As String)
    Dim Cn As ADODB.Connection
    Dim NomFeuille As String, texte_SQL As String
    Dim Rst As ADODB.Recordset
    Dim oCat As ADOX.Catalog
    Dim Resultat As String
    Dim Feuille As ADOX.Table
    
    Set Cn = New ADODB.Connection
    Set oCat = New ADOX.Catalog
    
    With Cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & chemin & ";Extended Properties=""Excel 12.0;HDR=YES;"""
        .Open
    End With
    
    Set oCat.ActiveConnection = Cn
        
    For Each Feuille In oCat.Tables
        Resultat = Feuille.Name
    Next
    
    'Nom de la feuille dans le classeur fermé
    NomFeuille = Resultat
    
    'Définit la requête.
    '/!\ Attention à ne pas oublier le symbole $ après le nom de la feuille.
    texte_SQL = "SELECT * FROM [" & NomFeuille & "]"
    
    Set Rst = New ADODB.Recordset
    Set Rst = Cn.Execute(texte_SQL)
    
    'Ecrit le résultat de la requête dans la cellule A1
    Range("A1").CopyFromRecordset Rst
    
    '--- Fermeture connexion ---
     Set Feuille = Nothing
    Set oCat = Nothing
    Cn.Close
    Set Cn = Nothing
End Sub


Tu gagnes en rapidité vu que tu n'ouvres pas chaque classeur!

@+ Le Pivert
Commenter la réponse de cs_Le Pivert
Messages postés
511
Date d'inscription
mardi 5 août 2008
Statut
Membre
Dernière intervention
2 décembre 2019
3
0
Merci
Bonjour Pivert,

Merci pour ta réponse.
Je testerais ça dès que possible mais là il faut que je reprenne dans l'urgence un autre classeur pour lequel je vais peut être avoir besoin d'aide.

Je reviens vers toi dès que possible.
Cordialement
Mistarl
Commenter la réponse de Mistral_13200