Regrouper plusieurs feuilles et modules dans un seul classeur

Bonjour Claudy,

Voici une procédure qui fait le travail... elle est testée très sommairement ...!

Afin que tu puisses te retrouver, chaque feuille recopiée dans le nouveau classeur prend le nom du classeur + un index
de ce type NomClasseur & "_" & A. IL en va de même pour tous les noms des composants VBA. Évidemment ceci devrait
éviter les bugs dus au doublon possible ...

Mais selon le code que tes classeurs contiennent, cela pourrait causer une certaine problématique de références ...

Copie le code qui suit dans un module standard du classeur devant regrouper tous les classeurs de ton répertoire que tu
prendras soin d'identifier dans la procédure.
'-------------------------------
Sub Copier()

Dim Tblo
Dim Repertoire As String
Dim wk As Workbook
Dim wk1 As Workbook

Set wk = ThisWorkbook

Repertoire = "c:excel" 'à déterminer

Tblo = Dir(Repertoire)

While Tblo <> ""
If LCase(Right(Tblo, 4)) = ".xls" Then
Set wk1 = Workbooks.Open(Tblo)
RenommerLesFeuilles wk1
RenommerLesModules wk1
'Copier toutes les feuilles
wk1.Worksheets.Copy wk.Worksheets(Sheets.Count)
'copier Tous les modules
CopierTousLesModules wk1, wk
wk1.Close False
End If
Tblo = Dir()
Wend

End Sub
'-------------------------------
Sub RenommerLesFeuilles(wk As Workbook)
Dim A As Integer
For Each sh In wk.sheets
A = A + 1
sh.Name = Left(wk.Name, Len(wk.Name) - 4) & "_" & A
Next
End Sub
'-------------------------------
Sub RenommerLesModules(wk As Workbook)
Dim A As Integer, Comp as object
For Each comp In wk.VBProject.VBComponents
A = A + 1
comp.Name = Left(wk.Name, Len(wk.Name) - 4) & "_" & A
Next
End Sub
'-------------------------------
Sub CopierTousLesModules(wk1 As Workbook, wk As Workbook)
Dim P as Object, Comp as object
For Each comp In wk1.VBProject.VBComponents
If comp.Type <> 100 Then
comp.Export "C:AAA"
Set p = wk.VBProject.VBComponents.Import("c:AAA")
p.Name = comp.Name
Kill "c:AAA"
End If
Next
End Sub
'-------------------------------


Salutations!




"claudy" <weets.claudy@Skynet.be.yenamarredesSpam> a écrit dans le message de news:
4232a14e$0$14965$ba620e4c@news.skynet.be...
Bonjour,
Jai dans un dossier, plusieurs classeurs Excel avec modules VBA,
comment regrouper tous mes classeurs en un seul classeur?
Merci d'avance,
Claudy
--
\ ////
( O O )
------oOOo-(_)-oOOo-----------------
Claudy

--------------Oooo------------------
oooO ( )
( ) ) /
( (_/
_)

à titre d'informations supplémentaires, il est à noter que le nom des feuilles (onglet) et le nom des objets "Module" ne
peuvent avoir plus de 31 caractères. De plus, les noms des modules ne peuvent être validés si ce dernier contient un
espace ...

Cette nouvelle version tient compte de ce qui précède ....

'-----------------------------------
Sub Copier()

Dim Tblo
Dim Repertoire As String
Dim wk As Workbook
Dim wk1 As Workbook

Set wk = ThisWorkbook

Repertoire = "c:excel"

Tblo = Dir(Repertoire)

While Tblo <> ""
If LCase(Right(Tblo, 4)) = ".xls" Then
Set wk1 = Workbooks.Open(Tblo)
RenommerLesFeuilles wk1
RenommerLesModules wk1
'Copier toutes les feuilles
wk1.Worksheets.Copy After:=wk.Sheets(wk.Sheets.Count)
'copier Tous les modules
CopierTousLesModules wk1, wk
wk1.Close False
End If
Tblo = Dir()
Wend

End Sub
'-----------------------------------
Sub RenommerLesFeuilles(wk As Workbook)
Dim A As Integer
For Each sh In wk.Worksheets
A = A + 1
sh.Name = Left(Left(wk.Name, Len(wk.Name) - 4), 28) & "_" & A
Next
End Sub
'-----------------------------------
Sub RenommerLesModules(wk As Workbook)
Dim A As Integer
For Each comp In wk.VBProject.VBComponents
A = A + 1
comp.Name = WorksheetFunction.Substitute(Left(Left(wk.Name, _
Len(wk.Name) - 4) & "_" & A, 28), " ", "_")
b = comp.Name
Next
End Sub
'-----------------------------------
Sub CopierTousLesModules(wk1 As Workbook, wk As Workbook)

For Each comp In wk1.VBProject.VBComponents
If comp.Type <> 100 Then
comp.Export "C:AAA"
Set p = wk.VBProject.VBComponents.Import("c:AAA")
p.Name = comp.Name
Kill "c:AAA"
End If
Next
End Sub
'-----------------------------------


Salutations!

Bonjour, et merci
J'ai bien déterminé le nom de mon répertoire,
mais la procédure bugge ici: Set wk1 = Workbooks.Open(Tblo)
erruer 1004, classeur introuvable alors qu'il me donne le bon nom de
classeur dans l'alerte!
On dirait que cela vient de Dir(Repertoire)
Qui ne me renvoie qu'un seul classeur de mon dossier alors qu'il y en a 5
a+
Claudy


"MichDenis" <michdenis@hotmail.com> a écrit dans le message de news:
uAa01SyJFHA.3552@TK2MSFTNGP12.phx.gbl...

à titre d'informations supplémentaires, il est à noter que le nom des
feuilles (onglet) et le nom des objets "Module" ne
peuvent avoir plus de 31 caractères. De plus, les noms des modules ne
peuvent être validés si ce dernier contient un
espace ...

Cette nouvelle version tient compte de ce qui précède ....

'-----------------------------------
Sub Copier()

Dim Tblo
Dim Repertoire As String
Dim wk As Workbook
Dim wk1 As Workbook

Set wk = ThisWorkbook

Repertoire = "c:excel"

Tblo = Dir(Repertoire)

While Tblo <> ""
If LCase(Right(Tblo, 4)) = ".xls" Then
Set wk1 = Workbooks.Open(Tblo)
RenommerLesFeuilles wk1
RenommerLesModules wk1
'Copier toutes les feuilles
wk1.Worksheets.Copy After:=wk.Sheets(wk.Sheets.Count)
'copier Tous les modules
CopierTousLesModules wk1, wk
wk1.Close False
End If
Tblo = Dir()
Wend

End Sub
'-----------------------------------
Sub RenommerLesFeuilles(wk As Workbook)
Dim A As Integer
For Each sh In wk.Worksheets
A = A + 1
sh.Name = Left(Left(wk.Name, Len(wk.Name) - 4), 28) & "_" & A
Next
End Sub
'-----------------------------------
Sub RenommerLesModules(wk As Workbook)
Dim A As Integer
For Each comp In wk.VBProject.VBComponents
A = A + 1
comp.Name = WorksheetFunction.Substitute(Left(Left(wk.Name, _
Len(wk.Name) - 4) & "_" & A, 28), " ", "_")
b = comp.Name
Next
End Sub
'-----------------------------------
Sub CopierTousLesModules(wk1 As Workbook, wk As Workbook)

For Each comp In wk1.VBProject.VBComponents
If comp.Type <> 100 Then
comp.Export "C:AAA"
Set p = wk.VBProject.VBComponents.Import("c:AAA")
p.Name = comp.Name
Kill "c:AAA"
End If
Next
End Sub
'-----------------------------------


Salutations!

Bonjour Claudy,

Tu dois modifier ceci : Set wk1 = Workbooks.Open(Tblo)

Par :

Set wk1 = Workbooks.Open(Repertoire & Tblo)

P.S. Par défaut, lorsque je fais mes tests, excel va voir dans le répertoire définit là :
barre de menus / outils / options / Onglet Général / Répertoire par défaut....cependant, lorsque les fichiers sont
situés ailleurs, on doit insérer le chemin complet pour ouvrir le fichier et j'ai omis de le mentionner !


Salutations!


"claudy" <weets.claudy@Skynet.be.yenamarredesSpam> a écrit dans le message de news:
4233ffa7$0$20673$ba620e4c@news.skynet.be...
Bonjour, et merci
J'ai bien déterminé le nom de mon répertoire,
mais la procédure bugge ici: Set wk1 = Workbooks.Open(Tblo)
erruer 1004, classeur introuvable alors qu'il me donne le bon nom de
classeur dans l'alerte!
On dirait que cela vient de Dir(Repertoire)
Qui ne me renvoie qu'un seul classeur de mon dossier alors qu'il y en a 5
a+
Claudy


"MichDenis" <michdenis@hotmail.com> a écrit dans le message de news:
uAa01SyJFHA.3552@TK2MSFTNGP12.phx.gbl...

à titre d'informations supplémentaires, il est à noter que le nom des
feuilles (onglet) et le nom des objets "Module" ne
peuvent avoir plus de 31 caractères. De plus, les noms des modules ne
peuvent être validés si ce dernier contient un
espace ...

Cette nouvelle version tient compte de ce qui précède ....

'-----------------------------------
Sub Copier()

Dim Tblo
Dim Repertoire As String
Dim wk As Workbook
Dim wk1 As Workbook

Set wk = ThisWorkbook

Repertoire = "c:excel"

Tblo = Dir(Repertoire)

While Tblo <> ""
If LCase(Right(Tblo, 4)) = ".xls" Then
Set wk1 = Workbooks.Open(Tblo)
RenommerLesFeuilles wk1
RenommerLesModules wk1
'Copier toutes les feuilles
wk1.Worksheets.Copy After:=wk.Sheets(wk.Sheets.Count)
'copier Tous les modules
CopierTousLesModules wk1, wk
wk1.Close False
End If
Tblo = Dir()
Wend

End Sub
'-----------------------------------
Sub RenommerLesFeuilles(wk As Workbook)
Dim A As Integer
For Each sh In wk.Worksheets
A = A + 1
sh.Name = Left(Left(wk.Name, Len(wk.Name) - 4), 28) & "_" & A
Next
End Sub
'-----------------------------------
Sub RenommerLesModules(wk As Workbook)
Dim A As Integer
For Each comp In wk.VBProject.VBComponents
A = A + 1
comp.Name = WorksheetFunction.Substitute(Left(Left(wk.Name, _
Len(wk.Name) - 4) & "_" & A, 28), " ", "_")
b = comp.Name
Next
End Sub
'-----------------------------------
Sub CopierTousLesModules(wk1 As Workbook, wk As Workbook)

For Each comp In wk1.VBProject.VBComponents
If comp.Type <> 100 Then
comp.Export "C:AAA"
Set p = wk.VBProject.VBComponents.Import("c:AAA")
p.Name = comp.Name
Kill "c:AAA"
End If
Next
End Sub
'-----------------------------------


Salutations!