Modification macro pour Excel 2010

Bonjour à tous,

J'ai un petit problème sur une macro que j'utilisais sur Excel 2002 mais qui ne fonctionne plus pour Excel 2010.

Tout d'abord, j'ai corrigé le beug créé par "Code Set fs = Application.FileSearch" mais désormais, autre chose me bloque .LookIn = rep

J'ai le message suivant :

Erreur d'exécution '424':

Objet requis

Si quelqu'un sait comment corriger cela...

Merci d'avance !!

option Explicit

End Function

Salut le forum

Regarde le lien suivant : Lister des fichiers d'un dossier dans Excel

Ton problème provient du fait que Application.FileSearch n'est pas supporté sous Excel 2007 et +

Mytå

Bonjour Myta,

Merci de vous intéresser à mon problème !

J'ai déjà réglé le problème de Application.FileSearch en ajoutant un complément dans mon Excel 2010

Et quand je relance la Macro, il met en surbrillance la ligne :

.LookIn = rep ' répertoire choisi

Est-ce que cela a un lien avec l'Application.FileSearch selon vous ? Je pensais que cela était un nouveau problème (LookIn = rep)disjoint du premier.

D'ailleurs la notification d'erreur est différente puisque le message affiché ici est une erreur d'exécution '424' alors que c'était autre chose avec Application.FileSeach...

Autant pour moi. Je n'avais pas collé la bonne macro. Je commence à m'embrouiller avec toutes ces tentatives !

J'utilise donc désormais ClFileSearch en remplacement d'Application.FileSearch

Voici le bon code dont le problème reste le même (Erreur 424 sur .LookIn = rep) :

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

Dim recherche As ClFileSearch.ClasseFileSearch

Set recherche = ClFileSearch.Nouvelle_Recherche

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 recherche = ClFileSearch.Nouvelle_Recherche

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:="bonuspool2010" ' 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

Re le forum

A quoi correspond fs dans ton code . . .

With fs

Mytå

Re

Dim fs As Variant ' système fichiers

Adou

Re le forum

Non , Fs est vide car tu ne lui affecte rien.

Exemple : Ici Fs est attribué (1er code)

Dim fs As Variant ' système fichiers
'...
Set fs = Application.FileSearch ' recherche fichiers
'...
With fs

Et dans ton deuxième code aucune référence (Set) n'est faite à Fs

Mytå

Effectivement... Merci

Mais désormais lorsque je lance la macro, il me met en surbillance .LookIn = et le message suivant apparait :

"Erreur de compilation:

Référence incorrecte ou non qualifiée"