Bonjour à tous,
tout d’abord je vous remercie de m'avoir permis de rejoindre ce forum, je me permets d'exposer mon problème :
ci-dessous une macro qui fait la fusion des plusieurs classeurs en un seul, cela dit mon soucis est que:
1 - Qu'elle détecte que les classeurs en version excel 97-2003, comment je peux l’actualiser pour qu'elle détecte même la version 2016 ( j'ai essayé avec l’extension *.xlsx ça ne marche pas )
2 - elle ne détecte pas aussi les classeurs avec plusieurs feuilles, elle copie que la première feuille ;
merci d'avance pour votre aide .
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
Dim fic_1 As String ' nom fichier sans extension
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 & "*.xls") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
chemin = rep & fic ' chemin fichiers
Workbooks.Open chemin, 0 ' ouverture
fic_1 = Split(ActiveWorkbook.Name, ".")(0)
Set Wl = ActiveWorkbook.Sheets(1)
Wl.Copy After:=Wf
ActiveSheet.Name = fic_1
Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
Set Wl = Nothing
End If
fic = Dir
Wend
fin:
MsgBox nbc & " classeurs regroupés"
Application.DisplayAlerts = True
End Sub
tout d’abord je vous remercie de m'avoir permis de rejoindre ce forum, je me permets d'exposer mon problème :
ci-dessous une macro qui fait la fusion des plusieurs classeurs en un seul, cela dit mon soucis est que:
1 - Qu'elle détecte que les classeurs en version excel 97-2003, comment je peux l’actualiser pour qu'elle détecte même la version 2016 ( j'ai essayé avec l’extension *.xlsx ça ne marche pas )
2 - elle ne détecte pas aussi les classeurs avec plusieurs feuilles, elle copie que la première feuille ;
merci d'avance pour votre aide .
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
Dim fic_1 As String ' nom fichier sans extension
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 & "*.xls") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
chemin = rep & fic ' chemin fichiers
Workbooks.Open chemin, 0 ' ouverture
fic_1 = Split(ActiveWorkbook.Name, ".")(0)
Set Wl = ActiveWorkbook.Sheets(1)
Wl.Copy After:=Wf
ActiveSheet.Name = fic_1
Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
Set Wl = Nothing
End If
fic = Dir
Wend
fin:
MsgBox nbc & " classeurs regroupés"
Application.DisplayAlerts = True
End Sub
