Bonjour à tous,
Me voilà bien embêté. Ma société est passée d'excel 2002 à excel 2010 et bien évidemment ma douce macro ne fontionne plus.
Visiblement le code Set fs = Application.FileSearch ne fonctionne plus sur cette version d'excel. J'en ai bien eu la confirmation sur différents forums mais je n'arrive pas à trouver la correction.
Mon code complet me permet de regrouper tous les fichiers Excel d'un dossier :
option Explicit
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Declare Function FindWindow32 Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Sub Recupere()
Dim fs As Variant ' système fichiers
Dim chemin As String ' classeur regroupé
Dim rep As String ' répertoire à traiter
Dim book As String ' classeur synthèse
Dim fic_lu As String ' classeur regroupé
Dim ligne As Long ' ligne écriture
Dim nbc As Integer ' nombre de classeurs
Dim nbf As Integer ' nombre de feuilles
Dim nbl As Integer ' nombre de lignes
Dim c As Integer ' nombre de colonnes
Dim i As Integer ' indice fichier
Dim j As Integer ' indice exclus
Dim k As Integer ' indice feuille
Dim l As Long ' ligne lecture
Dim Wb As Workbook ' classeur regroupement
Dim Wf As Worksheet ' feuille regroupement
Dim ndp As Long ' numéro de procédure
Dim mxc As Long ' maximum colones feuille
Dim mxl As Long ' maximum lignes feuille
Dim exclus() As Variant ' onglets exclus
exclus = Array("P de Garde", "Définition des colonnes") 'feuilles exclues regroupement
ndp = FindWindow32("XLMAIN", Application.Caption)
rep = rech_rep(ndp, "Choisissez le répertoire à regrouper")
If rep = "" Then Exit Sub
mxc = Cells(1, ActiveSheet.UsedRange.Columns.Count).End(xlToRight).Column
mxl = Cells(ActiveSheet.UsedRange.Rows.Count, 1).End(xlDown).Row
Application.ScreenUpdating = False
Application.EnableEvents = False
'On Error GoTo fin
book = ThisWorkbook.FullName ' Nom du classeur actuel
Set Wb = ThisWorkbook ' variable classeur groupe
Set Wf = Wb.ActiveSheet ' variable feuille groupe
nbc = 0: nbf = 0 ' initialisation variables
Set fs = Application.FileSearch ' recherche fichiers
ligne = 1
With fs
.LookIn = rep ' répertoire choisi
.Filename = "*.xls" ' classeurs Excel
.SearchSubFolders = True ' recherche sous répertoires
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderDescending) > 0 Then
For i = 1 To .FoundFiles.Count ' recherche fichiers
chemin = .FoundFiles(i) ' chemin fichiers
If chemin <> book Then ' différent du classeur regroupant
Workbooks.Open chemin, Password:="" ' ouverture
For k = 1 To Sheets.Count ' traitement onglets
For j = 0 To UBound(exclus)
If Not Sheets(k).Type < 0 Then Exit For
If Sheets(k).Name = exclus(j) Then Exit For
Next j
If j > UBound(exclus) Then
Sheets(k).Activate
nbl = ActiveSheet.UsedRange.Rows.Count
If ligne + nbl > mxl Then
ligne = 1 ' feuille pleine
Wb.Sheets.Add ' ajout d'une feuille
Set Wf = Wb.ActiveSheet
End If ' nom et contenu classeur
c = ActiveSheet.UsedRange.Columns.Count
If c = mxc Then c = mxc - 1
Wf.Hyperlinks.Add Anchor:=Wf.Cells(ligne, 1), Address:=chemin, _
TextToDisplay:=ActiveWorkbook.Name & " [" & Sheets(k).Name & "]"
' If ligne > 2 Then l = 3 Else l = 1 ' une seule fois le titre
l = 1
Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 2)
Wf.Cells(ligne, 1).Resize(nbl, 1).FillDown
ligne = ligne + nbl
nbf = nbf + 1
End If
Next k
ActiveWorkbook.Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
Next i
For l = ligne To 2 Step -1
If Wf.Cells(ligne, mxc).End(xlToLeft).Column = 1 _
And Wf.Cells(ligne, 1).Value = "" Then
Wf.Rows(ligne).Delete
ligne = ligne - 1
End If
Next l
End If
End With
fin:
MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Function rech_rep(hWndOwner As Long, msg As String) As String
Dim lng As Integer ' longueur string répertoire choisi
Dim choix As Long ' choix répertoire effectué
Dim res As Long ' réponse fonction
Dim rep As String ' répertoire choisi
Dim pbi As BrowseInfo ' paramètre browser infos
pbi.hWndOwner = hWndOwner
pbi.lpszTitle = lstrcat(msg, "")
pbi.ulFlags = BIF_RETURNONLYFSDIRS
choix = SHBrowseForFolder(pbi) ' affichage menu sélection
If choix Then ' récupération répertoire
rep = String$(MAX_PATH, 0)
res = SHGetPathFromIDList(choix, rep)
Call CoTaskMemFree(choix)
lng = InStr(rep, vbNullChar)
If lng Then rep = Left$(rep, lng - 1)
End If
rech_rep = rep
End Function
Voilà voilà....
En espérant que quelqu'un aura une solution miracle !!
Merci d'avance
Me voilà bien embêté. Ma société est passée d'excel 2002 à excel 2010 et bien évidemment ma douce macro ne fontionne plus.
Visiblement le code Set fs = Application.FileSearch ne fonctionne plus sur cette version d'excel. J'en ai bien eu la confirmation sur différents forums mais je n'arrive pas à trouver la correction.
Mon code complet me permet de regrouper tous les fichiers Excel d'un dossier :
option Explicit
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Declare Function FindWindow32 Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Sub Recupere()
Dim fs As Variant ' système fichiers
Dim chemin As String ' classeur regroupé
Dim rep As String ' répertoire à traiter
Dim book As String ' classeur synthèse
Dim fic_lu As String ' classeur regroupé
Dim ligne As Long ' ligne écriture
Dim nbc As Integer ' nombre de classeurs
Dim nbf As Integer ' nombre de feuilles
Dim nbl As Integer ' nombre de lignes
Dim c As Integer ' nombre de colonnes
Dim i As Integer ' indice fichier
Dim j As Integer ' indice exclus
Dim k As Integer ' indice feuille
Dim l As Long ' ligne lecture
Dim Wb As Workbook ' classeur regroupement
Dim Wf As Worksheet ' feuille regroupement
Dim ndp As Long ' numéro de procédure
Dim mxc As Long ' maximum colones feuille
Dim mxl As Long ' maximum lignes feuille
Dim exclus() As Variant ' onglets exclus
exclus = Array("P de Garde", "Définition des colonnes") 'feuilles exclues regroupement
ndp = FindWindow32("XLMAIN", Application.Caption)
rep = rech_rep(ndp, "Choisissez le répertoire à regrouper")
If rep = "" Then Exit Sub
mxc = Cells(1, ActiveSheet.UsedRange.Columns.Count).End(xlToRight).Column
mxl = Cells(ActiveSheet.UsedRange.Rows.Count, 1).End(xlDown).Row
Application.ScreenUpdating = False
Application.EnableEvents = False
'On Error GoTo fin
book = ThisWorkbook.FullName ' Nom du classeur actuel
Set Wb = ThisWorkbook ' variable classeur groupe
Set Wf = Wb.ActiveSheet ' variable feuille groupe
nbc = 0: nbf = 0 ' initialisation variables
Set fs = Application.FileSearch ' recherche fichiers
ligne = 1
With fs
.LookIn = rep ' répertoire choisi
.Filename = "*.xls" ' classeurs Excel
.SearchSubFolders = True ' recherche sous répertoires
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderDescending) > 0 Then
For i = 1 To .FoundFiles.Count ' recherche fichiers
chemin = .FoundFiles(i) ' chemin fichiers
If chemin <> book Then ' différent du classeur regroupant
Workbooks.Open chemin, Password:="" ' ouverture
For k = 1 To Sheets.Count ' traitement onglets
For j = 0 To UBound(exclus)
If Not Sheets(k).Type < 0 Then Exit For
If Sheets(k).Name = exclus(j) Then Exit For
Next j
If j > UBound(exclus) Then
Sheets(k).Activate
nbl = ActiveSheet.UsedRange.Rows.Count
If ligne + nbl > mxl Then
ligne = 1 ' feuille pleine
Wb.Sheets.Add ' ajout d'une feuille
Set Wf = Wb.ActiveSheet
End If ' nom et contenu classeur
c = ActiveSheet.UsedRange.Columns.Count
If c = mxc Then c = mxc - 1
Wf.Hyperlinks.Add Anchor:=Wf.Cells(ligne, 1), Address:=chemin, _
TextToDisplay:=ActiveWorkbook.Name & " [" & Sheets(k).Name & "]"
' If ligne > 2 Then l = 3 Else l = 1 ' une seule fois le titre
l = 1
Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 2)
Wf.Cells(ligne, 1).Resize(nbl, 1).FillDown
ligne = ligne + nbl
nbf = nbf + 1
End If
Next k
ActiveWorkbook.Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
Next i
For l = ligne To 2 Step -1
If Wf.Cells(ligne, mxc).End(xlToLeft).Column = 1 _
And Wf.Cells(ligne, 1).Value = "" Then
Wf.Rows(ligne).Delete
ligne = ligne - 1
End If
Next l
End If
End With
fin:
MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Function rech_rep(hWndOwner As Long, msg As String) As String
Dim lng As Integer ' longueur string répertoire choisi
Dim choix As Long ' choix répertoire effectué
Dim res As Long ' réponse fonction
Dim rep As String ' répertoire choisi
Dim pbi As BrowseInfo ' paramètre browser infos
pbi.hWndOwner = hWndOwner
pbi.lpszTitle = lstrcat(msg, "")
pbi.ulFlags = BIF_RETURNONLYFSDIRS
choix = SHBrowseForFolder(pbi) ' affichage menu sélection
If choix Then ' récupération répertoire
rep = String$(MAX_PATH, 0)
res = SHGetPathFromIDList(choix, rep)
Call CoTaskMemFree(choix)
lng = InStr(rep, vbNullChar)
If lng Then rep = Left$(rep, lng - 1)
End If
rech_rep = rep
End Function
Voilà voilà....
En espérant que quelqu'un aura une solution miracle !!
Merci d'avance
