Discussion :

[meumeu73.1]

Bonjour,

Je suis à la recherche d'une macro qui pourra scanner un répertoire ouvrir les fichiers excel disponible dans ce répertoire et créer dans un autre répertoire un fichier excel qui aura récupérer toutes les feuilles disponibles sans faire de fusion entre les feuilles car celles ci auront un nom différent.

Par avance merci.

[Ashireon]

Hello,

- Attention tu es limité au nombre de feuilles dans un classeur qui doit être de 255 au total.
- Comment veux tu renommer la feuille copié ?
- Tout les fichiers Excel ont ils la même extension ?
Le fichier qui a la Macro est il le fichiers de réception de ces feuilles ?

[meumeu73.1]

il n'y aura pas plus de 255 feuilles ce qui est sur.

je conserve le nom d'origine des feuilles

tous les fichiers auront la même extension

non, se serait dans l'idéal un autre fichier.

[Ashireon]

Donc En gros tu a un fichier Y qui lance la macro.
Qui scan et copie les feuilles d'un ensemble Z de fichiers et les copie Vers un fichier W.
C'est faisable.
Je regarde pour faire le Code.

[meumeu73.1]

c'est bien cela, super merci beaucoup

[Ashireon]

Hello,
Voici la macro
Donc la macro c'est celle nomée Principal.
On te demande le répertoire source.
Le nom des feuilles crées est compose du workbook d'origine et du nom de la feuille d'origine pour eviter des erreur de nom en doublons style plusieurs Feuil1 dans plusieurs fichiers...
A la fin de la procédure tu a un save as pour dire ou tu veux sauvegarder le fichier résultat.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Dim WbkDestination As Workbook
Dim WbkSource As Workbook
Public Function ChoixDoss() As String
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, "c:\")
If oFolder Is Nothing Then
    MsgBox "Abandon opérateur", vbCritical
Else
  Set oFolderItem = oFolder.Self
  ChoixDoss = oFolderItem.Path
End If
End Function
Sub CopiesFeuilles(ByVal wbks As Workbook, ByVal wbkd As Workbook)
Dim sh As Variant
 
    For Each sh In wbks.Sheets
        sh.Copy after:=wbkd.Sheets(wbkd.Sheets.Count)
 
        wbkd.Sheets(wbkd.Sheets.Count).Name = wbks.Name & "_" & sh.Name
 
    Next
 
End Sub
Sub ouvertureFichier()
Dim Fichier As String
Dim nom As String
Dim Dossier As String
Dossier = ChoixDoss & "\"
 
Fichier = Dir(Dossier & "*.xls")
 
Dim sh As Variant
 
Do While Fichier <> ""
 
    Set WbkSource = Workbooks.Open(Dossier & Fichier)
        If WbkDestination.Sheets.Count < 255 Then
            Call CopiesFeuilles(WbkSource, WbkDestination)
        Else
            MsgBox ("Le maximum de Feuilles copiables est atteint")
            WbkSource.Close
            Set WbkSource = Nothing
            Fichier = Dir
            WbkDestination.SaveAs (Application.Dialogs(xlDialogSaveAs).Show)
            WbkDestination.Close
            Exit Do
        End If
 
    WbkSource.Close
    Set WbkSource = Nothing
    Fichier = Dir
 
Loop
WbkDestination.Sheets("Feuil1").Delete
WbkDestination.Sheets("Feuil2").Delete
WbkDestination.Sheets("Feuil3").Delete
WbkDestination.SaveAs (Application.Dialogs(xlDialogSaveAs).Show)
WbkDestination.Close
 
End Sub
 
 
Sub Principal()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Set WbkDestination = Workbooks.Add
 
 
Call ouvertureFichier
 
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub