Compilation fichiers sous Excel 2003 ne fonctionne plus sous Excel 2013
13 réponses
mclain
Bonsoir =E0 tous,
J'utilisais jusqu'ici un petit script excel 2003 qui me servait =E0 compile=
r diff=E9rents fichiers excel sous une seule et m=EAme feuille.
Or nous venons de migrer en 2013.
Du coup j'ai une erreur que je n'arrive pas =E0 r=E9soudre.
Je pense ne pas =EAtre le seul =E0 l'utiliser.
Voici le script
Erreur compilation=20
Verifiez et mettez =E0 jour les instructions Declare, puis marquez-les avec=
l'attribut PtrSafe...
J'esp=E8re que vous pourrez m'aider car je ne vois pas...
mes comp=E9tences sont bien trop limit=E9es.
Merci d'avance !
Mclain
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
Declare Function FindWindow32 Lib "user32" Alias "FindWindowA" (ByVal lpCla=
ssName 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 lpS=
tring1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInf=
o) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList A=
s Long, ByVal lpBuffer As String) As Long
Public Sub Recupere()
Dim fs As Variant ' syst=E8me fichiers
Dim chemin As String ' classeur regroup=E9
Dim rep As String ' r=E9pertoire =E0 traiter
Dim book As String ' classeur synth=E8se
Dim fic_lu As String ' classeur regroup=E9
Dim ligne As Long ' ligne =E9criture
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=E9ro de proc=E9dure
Dim mxc As Long ' maximum colones feuille
Dim mxl As Long ' maximum lignes feuille
Dim exclus() As Variant ' onglets exclus
exclus =3D Array("P de Garde", "D=E9finition des colonnes") 'feuilles exclu=
es regroupement
ndp =3D FindWindow32("XLMAIN", Application.Caption)
rep =3D rech_rep(ndp, "Choisissez le r=E9pertoire =E0 regrouper")
If rep =3D "" Then Exit Sub
mxc =3D Cells(1, ActiveSheet.UsedRange.Columns.Count).End(xlToRight).Column
mxl =3D Cells(ActiveSheet.UsedRange.Rows.Count, 1).End(xlDown).Row
Application.ScreenUpdating =3D False
Application.EnableEvents =3D False
'On Error GoTo fin
book =3D ThisWorkbook.FullName ' Nom du classeur actuel
Set Wb =3D ThisWorkbook ' variable classeur groupe
Set Wf =3D Wb.ActiveSheet ' variable feuille groupe
nbc =3D 0: nbf =3D 0 ' initialisation variables
Set fs =3D Application.FileSearch ' recherche fichiers
ligne =3D 1
With fs
.LookIn =3D rep ' r=E9pertoire choisi
.Filename =3D "*.xls" ' classeurs Excel
.SearchSubFolders =3D True ' recherche sous r=E9pertoires
If .Execute(SortBy:=3DmsoSortByLastModified, SortOrder:=3DmsoSortOrderD=
escending) > 0 Then
For i =3D 1 To .FoundFiles.Count ' recherche fichiers
chemin =3D .FoundFiles(i) ' chemin fichiers
If chemin <> book Then ' diff=E9rent du classeur regroupan=
t
Workbooks.Open chemin, 0 ' ouverture
For k =3D 1 To Sheets.Count ' traitement onglets
For j =3D 0 To UBound(exclus)
If Not Sheets(k).Type < 0 Then Exit For
If Sheets(k).Name =3D exclus(j) Then Exit For
Next j
If j > UBound(exclus) Then
Sheets(k).Activate
nbl =3D ActiveSheet.UsedRange.Rows.Count
If ligne + nbl > mxl Then
ligne =3D 1 ' feuille pleine
Wb.Sheets.Add ' ajout d'une feuille
Set Wf =3D Wb.ActiveSheet
End If ' nom et contenu classeur
c =3D ActiveSheet.UsedRange.Columns.Count
If c =3D mxc Then c =3D mxc - 1
Wf.Hyperlinks.Add Anchor:=3DWf.Cells(ligne, 1), Address=
:=3Dchemin, _
TextToDisplay:=3DActiveWorkbook.Name & " [" & Sheet=
s(k).Name & "]"
' If ligne > 2 Then l =3D 3 Else l =3D 1 ' une seule fo=
is le titre
l =3D 1
Cells(l, 1).Resize(nbl, c).Copy Destination:=3DWf.Cells=
(ligne, 2)
Wf.Cells(ligne, 1).Resize(nbl, 1).FillDown
ligne =3D ligne + nbl
nbf =3D nbf + 1
End If
Next k
ActiveWorkbook.Close SaveChanges:=3DFalse ' Fermeture du =
classeur
nbc =3D nbc + 1
End If
Next i
For l =3D ligne To 2 Step -1
If Wf.Cells(ligne, mxc).End(xlToLeft).Column =3D 1 _
And Wf.Cells(ligne, 1).Value =3D "" Then
Wf.Rows(ligne).Delete
ligne =3D ligne - 1
End If
Next l
End If
End With
fin:
MsgBox nbc & " classeurs regroup=E9s avec " & nbf & " feuilles et " & l=
igne & " lignes"
Application.ScreenUpdating =3D True
Application.EnableEvents =3D True
End Sub
Private Function rech_rep(hWndOwner As Long, msg As String) As String
Dim lng As Integer ' longueur string r=E9pertoire choisi
Dim choix As Long ' choix r=E9pertoire effectu=E9
Dim res As Long ' r=E9ponse fonction
Dim rep As String ' r=E9pertoire choisi
Dim pbi As BrowseInfo ' param=E8tre browser infos
choix =3D SHBrowseForFolder(pbi) ' affichage menu s=E9lection
If choix Then ' r=E9cup=E9ration r=E9pertoire
rep =3D String$(MAX_PATH, 0)
res =3D SHGetPathFromIDList(choix, rep)
Call CoTaskMemFree(choix)
lng =3D InStr(rep, vbNullChar)
If lng Then rep =3D Left$(rep, lng - 1)
End If
rech_rep =3D rep
End Function
Je n'ai pas l'environnement propice pour tester cette procédure mais tu dois adapter la déclaration des API comme ceci :
Attention aux coupures de ligne dans les déclarations suivantes. Une ligne par déclaration. Tu ne dois pas enlever les dièses (#) devant le if else then puisque c'est ce qui permet d'avoir une compilation conditionnelle selon que ton Windows est 32 bits ou 64 bits.
Si ta version d'Excel est plus grande qu'Excel 2007, cela devrait fonctionner correctement (évidemment il reste à tester!)
#If Win64 Then Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Declare PtrSafe Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Declare PtrSafe Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long #Else Declare Function FindWindow32 Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As LongPtr Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long #End If
au lieu de cela :
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
Et que la chance soit avec toi! ;-))
MichD
Bonjour,
Je n'ai pas l'environnement propice pour tester cette procédure mais tu
dois adapter la déclaration des API comme ceci :
Attention aux coupures de ligne dans les déclarations suivantes.
Une ligne par déclaration.
Tu ne dois pas enlever les dièses (#) devant le if else then
puisque c'est ce qui permet d'avoir une compilation conditionnelle
selon que ton Windows est 32 bits ou 64 bits.
Si ta version d'Excel est plus grande qu'Excel 2007, cela devrait
fonctionner correctement (évidemment il reste à tester!)
#If Win64 Then
Declare PtrSafe Function FindWindow Lib "user32" Alias
"FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As
String) As LongPtr
Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA"
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
Declare PtrSafe Function SHBrowseForFolder Lib "shell32" (lpbi As
BrowseInfo) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32" (ByVal
pidList As Long, ByVal lpBuffer As String) As Long
#Else
Declare Function FindWindow32 Lib "user32" Alias "FindWindowA"
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA"
(ByVal lpString1 As String, ByVal lpString2 As String) As LongPtr
Declare Function SHBrowseForFolder Lib "shell32" (lpbi As
BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList
As Long, ByVal lpBuffer As String) As Long
#End If
au lieu de cela :
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
Je n'ai pas l'environnement propice pour tester cette procédure mais tu dois adapter la déclaration des API comme ceci :
Attention aux coupures de ligne dans les déclarations suivantes. Une ligne par déclaration. Tu ne dois pas enlever les dièses (#) devant le if else then puisque c'est ce qui permet d'avoir une compilation conditionnelle selon que ton Windows est 32 bits ou 64 bits.
Si ta version d'Excel est plus grande qu'Excel 2007, cela devrait fonctionner correctement (évidemment il reste à tester!)
#If Win64 Then Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Declare PtrSafe Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Declare PtrSafe Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long #Else Declare Function FindWindow32 Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As LongPtr Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long #End If
au lieu de cela :
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
Et que la chance soit avec toi! ;-))
MichD
mclain
Bonsoir MichD,
J'ai tout fait comme tu m'indiques mais j'ai une erreur dans le script apr ès J'ai mis mon fichier excel
http://www.cjoint.com/c/FDuuPbPcjU0
Encore merci à toi pour ton aide
Mclain
Bonsoir MichD,
J'ai tout fait comme tu m'indiques mais j'ai une erreur dans le script apr ès
J'ai mis mon fichier excel
J'ai tout fait comme tu m'indiques mais j'ai une erreur dans le script apr ès J'ai mis mon fichier excel
http://www.cjoint.com/c/FDuuPbPcjU0
Encore merci à toi pour ton aide
Mclain
MichD
Je n'avais pas lu au complet ta procédure, je n'étais arrêté à la déclaration des API.
Excel 2003 est la dernière version où tu peux utiliser l'objet "FileSearch". Cet objet n'est pas disponible dans les versions plus récentes d'Excel. (Set fs = Application.FileSearch)
Je te propose une autre avenue, et ce sans l'utilisation des API de Windows. Cette approche est un peu plus rapide, mais beaucoup plus difficile à coder.
Voici mon exemple avec quelques explications dans le code. Le code est loin d'être complet, cela requiert un peu trop d'énergie et de temps pour comprendre ce que tu tentes de faire et de le transposer dans la nouvelle procédure...
Bon travail!
'Déclaration des variables dans le haut du module Dim FSO As Object Dim myBaseFolder As Object Dim myFolder As Object Dim Tblo() As String Dim F As Object, X As Long
'-------------------------------------------------------------- Sub FoldersList() Dim répertoireSource As String Dim RépertoireDestination As String
'********Définir les variables*********** 'Répertoire de départ répertoireSource = "c:UsersMichDDocuments"
'Si tu veux qu'un usager choisisse un répertoire, 'le chemin indiqué est le répertoire où la fenêtre s'ouvrira 'c'est une valeur par défaut, à toi d'indiquer celle que tu 'désires
RépertoireDestination = SelDossier("C:UsersMichDDocuments") 'Ne pas oublier le "" '****************************************
X = 1 Set FSO = CreateObject("scripting.filesystemobject") On Error Resume Next Call FoldersInFolder(répertoireSource, RépertoireDestination) End Sub
'-------------------------------------------------------------- Sub FoldersInFolder(myFolderName As String, Dest As String) 'Cette procédure regroupe dans la variable "Tblo", tous les 'fichiers contenus dans le répertoire de départ ainsi que les 'fichiers Excel contenus dans les sous-répertoires du répertoire 'de départ
Set myBaseFolder = FSO.getfolder(myFolderName) For Each F In myBaseFolder.Files If F.Name Like "*.xl*" Then With FSO.GetFile(myFolderName & F.Name) 'un test afin de déterminer si la date de création 'est différente de la date de la dernière modification 'Dans le cas où les 2 dates sont les mêmes, le fichier 'n'a pas été modifié et il ne devrait pas faire partie 'de la liste... If .DateCreated <> .DateLastModified Then ReDim Preserve Tblo(1 To X) Tblo(X) = myFolderName & F.Name X = X + 1 End If End With End If Next
'Cette section s'occupe de traiter (appeler) les sous-répertoires. For Each myFolder In myBaseFolder.SubFolders Call FoldersInFolder(myFolder.Path, Dest) Next
Call Seuls_Les_Classeurs_Modifiés(Tblo, Dest) End Sub
Sub Seuls_Les_Classeurs_Modifiés(Tblo, Dest As String) 'Tblo = Liste des fichiers modifiés seulement 'Dest = le répertoire choisi par l'usager ou celui indiqué 'par défaut.
Dim Elt As Variant, K As Long
'Tu pourrais reprendre ta procédure à partir de la ligne de code suivante :
'pour chaque fichier dans le tableau For Each Elt In Tblo If Elt <> ThisWorkbook.FullName Then Workbooks.Open Elt, 0
For K = 1 To Sheets.Count ' traitement onglets 'le reste du code 'tu devras l'adapter quelque peu pour tenir compte des 'modifications de certaines variables.
Next End If Next
End Sub
'-------------------------------------------------------------- Function SelDossier(Defaut As String) 'procédure pour définir le répertoire choisi par l'usager Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .InitialFileName = Defaut If .Show = -1 Then SelDossier = fd.SelectedItems(1) End If End With Set fd = Nothing End Function '--------------------------------------------------------------
Je n'avais pas lu au complet ta procédure, je n'étais arrêté à la
déclaration des API.
Excel 2003 est la dernière version où tu peux utiliser l'objet
"FileSearch". Cet objet n'est pas disponible dans les versions plus
récentes d'Excel. (Set fs = Application.FileSearch)
Je te propose une autre avenue, et ce sans l'utilisation des API de
Windows. Cette approche est un peu plus rapide, mais beaucoup plus
difficile à coder.
Voici mon exemple avec quelques explications dans le code.
Le code est loin d'être complet, cela requiert un peu trop d'énergie
et de temps pour comprendre ce que tu tentes de faire et de le
transposer dans la nouvelle procédure...
Bon travail!
'Déclaration des variables dans le haut du module
Dim FSO As Object
Dim myBaseFolder As Object
Dim myFolder As Object
Dim Tblo() As String
Dim F As Object, X As Long
'--------------------------------------------------------------
Sub FoldersList()
Dim répertoireSource As String
Dim RépertoireDestination As String
'********Définir les variables***********
'Répertoire de départ
répertoireSource = "c:UsersMichDDocuments"
'Si tu veux qu'un usager choisisse un répertoire,
'le chemin indiqué est le répertoire où la fenêtre s'ouvrira
'c'est une valeur par défaut, à toi d'indiquer celle que tu
'désires
RépertoireDestination = SelDossier("C:UsersMichDDocuments")
'Ne pas oublier le ""
'****************************************
X = 1
Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
Call FoldersInFolder(répertoireSource, RépertoireDestination)
End Sub
'--------------------------------------------------------------
Sub FoldersInFolder(myFolderName As String, Dest As String)
'Cette procédure regroupe dans la variable "Tblo", tous les
'fichiers contenus dans le répertoire de départ ainsi que les
'fichiers Excel contenus dans les sous-répertoires du répertoire
'de départ
Set myBaseFolder = FSO.getfolder(myFolderName)
For Each F In myBaseFolder.Files
If F.Name Like "*.xl*" Then
With FSO.GetFile(myFolderName & F.Name)
'un test afin de déterminer si la date de création
'est différente de la date de la dernière modification
'Dans le cas où les 2 dates sont les mêmes, le fichier
'n'a pas été modifié et il ne devrait pas faire partie
'de la liste...
If .DateCreated <> .DateLastModified Then
ReDim Preserve Tblo(1 To X)
Tblo(X) = myFolderName & F.Name
X = X + 1
End If
End With
End If
Next
'Cette section s'occupe de traiter (appeler) les sous-répertoires.
For Each myFolder In myBaseFolder.SubFolders
Call FoldersInFolder(myFolder.Path, Dest)
Next
Call Seuls_Les_Classeurs_Modifiés(Tblo, Dest)
End Sub
Sub Seuls_Les_Classeurs_Modifiés(Tblo, Dest As String)
'Tblo = Liste des fichiers modifiés seulement
'Dest = le répertoire choisi par l'usager ou celui indiqué
'par défaut.
Dim Elt As Variant, K As Long
'Tu pourrais reprendre ta procédure à partir de la ligne de code suivante :
'pour chaque fichier dans le tableau
For Each Elt In Tblo
If Elt <> ThisWorkbook.FullName Then
Workbooks.Open Elt, 0
For K = 1 To Sheets.Count ' traitement onglets
'le reste du code
'tu devras l'adapter quelque peu pour tenir compte des
'modifications de certaines variables.
Next
End If
Next
End Sub
'--------------------------------------------------------------
Function SelDossier(Defaut As String)
'procédure pour définir le répertoire choisi par l'usager
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.InitialFileName = Defaut
If .Show = -1 Then
SelDossier = fd.SelectedItems(1)
End If
End With
Set fd = Nothing
End Function
'--------------------------------------------------------------
Je n'avais pas lu au complet ta procédure, je n'étais arrêté à la déclaration des API.
Excel 2003 est la dernière version où tu peux utiliser l'objet "FileSearch". Cet objet n'est pas disponible dans les versions plus récentes d'Excel. (Set fs = Application.FileSearch)
Je te propose une autre avenue, et ce sans l'utilisation des API de Windows. Cette approche est un peu plus rapide, mais beaucoup plus difficile à coder.
Voici mon exemple avec quelques explications dans le code. Le code est loin d'être complet, cela requiert un peu trop d'énergie et de temps pour comprendre ce que tu tentes de faire et de le transposer dans la nouvelle procédure...
Bon travail!
'Déclaration des variables dans le haut du module Dim FSO As Object Dim myBaseFolder As Object Dim myFolder As Object Dim Tblo() As String Dim F As Object, X As Long
'-------------------------------------------------------------- Sub FoldersList() Dim répertoireSource As String Dim RépertoireDestination As String
'********Définir les variables*********** 'Répertoire de départ répertoireSource = "c:UsersMichDDocuments"
'Si tu veux qu'un usager choisisse un répertoire, 'le chemin indiqué est le répertoire où la fenêtre s'ouvrira 'c'est une valeur par défaut, à toi d'indiquer celle que tu 'désires
RépertoireDestination = SelDossier("C:UsersMichDDocuments") 'Ne pas oublier le "" '****************************************
X = 1 Set FSO = CreateObject("scripting.filesystemobject") On Error Resume Next Call FoldersInFolder(répertoireSource, RépertoireDestination) End Sub
'-------------------------------------------------------------- Sub FoldersInFolder(myFolderName As String, Dest As String) 'Cette procédure regroupe dans la variable "Tblo", tous les 'fichiers contenus dans le répertoire de départ ainsi que les 'fichiers Excel contenus dans les sous-répertoires du répertoire 'de départ
Set myBaseFolder = FSO.getfolder(myFolderName) For Each F In myBaseFolder.Files If F.Name Like "*.xl*" Then With FSO.GetFile(myFolderName & F.Name) 'un test afin de déterminer si la date de création 'est différente de la date de la dernière modification 'Dans le cas où les 2 dates sont les mêmes, le fichier 'n'a pas été modifié et il ne devrait pas faire partie 'de la liste... If .DateCreated <> .DateLastModified Then ReDim Preserve Tblo(1 To X) Tblo(X) = myFolderName & F.Name X = X + 1 End If End With End If Next
'Cette section s'occupe de traiter (appeler) les sous-répertoires. For Each myFolder In myBaseFolder.SubFolders Call FoldersInFolder(myFolder.Path, Dest) Next
Call Seuls_Les_Classeurs_Modifiés(Tblo, Dest) End Sub
Sub Seuls_Les_Classeurs_Modifiés(Tblo, Dest As String) 'Tblo = Liste des fichiers modifiés seulement 'Dest = le répertoire choisi par l'usager ou celui indiqué 'par défaut.
Dim Elt As Variant, K As Long
'Tu pourrais reprendre ta procédure à partir de la ligne de code suivante :
'pour chaque fichier dans le tableau For Each Elt In Tblo If Elt <> ThisWorkbook.FullName Then Workbooks.Open Elt, 0
For K = 1 To Sheets.Count ' traitement onglets 'le reste du code 'tu devras l'adapter quelque peu pour tenir compte des 'modifications de certaines variables.
Next End If Next
End Sub
'-------------------------------------------------------------- Function SelDossier(Defaut As String) 'procédure pour définir le répertoire choisi par l'usager Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .InitialFileName = Defaut If .Show = -1 Then SelDossier = fd.SelectedItems(1) End If End With Set fd = Nothing End Function '--------------------------------------------------------------
isabelle
bonjour Denis,
j’apprécie beaucoup ton travail, et j'aimerais avoir ton avis sur l'utilisation de la variable Elt penses-tu qu'il serait possible de mettre cette variable en déclaration Public utilisable pour tous les codes, je fais cette demande car je voudrais que chaque fichier soit fermé après récupération des données, j'ai fais quelque test et je constate que lors d'un bug il reste beaucoup de fichier ouvert, Gros Merci! pour ton travail.
isabelle
bonjour Denis,
j’apprécie beaucoup ton travail, et j'aimerais avoir ton avis sur l'utilisation
de la variable Elt
penses-tu qu'il serait possible de mettre cette variable en déclaration Public
utilisable pour tous les codes,
je fais cette demande car je voudrais que chaque fichier soit fermé après
récupération des données,
j'ai fais quelque test et je constate que lors d'un bug il reste beaucoup de
fichier ouvert,
Gros Merci! pour ton travail.
j’apprécie beaucoup ton travail, et j'aimerais avoir ton avis sur l'utilisation de la variable Elt penses-tu qu'il serait possible de mettre cette variable en déclaration Public utilisable pour tous les codes, je fais cette demande car je voudrais que chaque fichier soit fermé après récupération des données, j'ai fais quelque test et je constate que lors d'un bug il reste beaucoup de fichier ouvert, Gros Merci! pour ton travail.
isabelle
mclain
Bonjour !
Grand merci à toi MichD ! Je vais essayer ce matin de faire tourner ce sc ript.
En fait, j'extrais des données identiques chaque semaine dans des fichier s numérotés Sem1, Sem2, Sem3. Chaque fichier est constitué d'environ 3000 lignes et de 60 colonnes (toujours identiques). De ces fichiers Hebdo, je veux compiler en seul fichier Excel. De la je peu x étudier certaines variables, rédondances et vérifier les actions me nées ou non chaque semaine. Voila pourquoi je compile tout ca. Sous excel 2003, un clic et l'assemblage se faisait super rapidement.
Je ne sais pas si je suis clair ?
Merci en tout cas pour ton aide et pour ton expertise au service des autres !
Mclain
Bonjour !
Grand merci à toi MichD ! Je vais essayer ce matin de faire tourner ce sc ript.
En fait, j'extrais des données identiques chaque semaine dans des fichier s numérotés Sem1, Sem2, Sem3. Chaque fichier est constitué d'environ 3000 lignes et de 60 colonnes (toujours identiques).
De ces fichiers Hebdo, je veux compiler en seul fichier Excel. De la je peu x étudier certaines variables, rédondances et vérifier les actions me nées ou non chaque semaine.
Voila pourquoi je compile tout ca. Sous excel 2003, un clic et l'assemblage se faisait super rapidement.
Je ne sais pas si je suis clair ?
Merci en tout cas pour ton aide et pour ton expertise au service des autres !
Grand merci à toi MichD ! Je vais essayer ce matin de faire tourner ce sc ript.
En fait, j'extrais des données identiques chaque semaine dans des fichier s numérotés Sem1, Sem2, Sem3. Chaque fichier est constitué d'environ 3000 lignes et de 60 colonnes (toujours identiques). De ces fichiers Hebdo, je veux compiler en seul fichier Excel. De la je peu x étudier certaines variables, rédondances et vérifier les actions me nées ou non chaque semaine. Voila pourquoi je compile tout ca. Sous excel 2003, un clic et l'assemblage se faisait super rapidement.
Je ne sais pas si je suis clair ?
Merci en tout cas pour ton aide et pour ton expertise au service des autres !
Mclain
MichD
Bonjour Isabelle,
Je te donne un exemple :
Dans le haut du module2, déclaration de la variable Elt Dim Elt as Variant
Dans la feuille module de la feuil1, cette procédure :
'-------------------------------- Sub test()
Dim T(1 To 3)
T(1) = "Isabelle" T(2) = "Nicole" T(3) = "Sylvie"
For Each Elt In T Call ValeurVariable(Elt) Next End Sub '--------------------------------
Et dans le module1, cette procédure : '-------------------------------- Sub ValeurVariable(V As Variant) MsgBox V End Sub '--------------------------------
Et ça fonctionne très bien, sans anicroche!
Habituellement, on attribue le type variant à la variable Elt dans une boucle d'un tableau, car le tableau peut prendre n'importe quelle valeur.
L'utilisation des différents modules, c'est juste pour faire réaliser qu'il n'y a pas une limite particulière à l'utilisation de cette variable.
MichD
Bonjour Isabelle,
Je te donne un exemple :
Dans le haut du module2, déclaration de la variable Elt
Dim Elt as Variant
Dans la feuille module de la feuil1, cette procédure :
'--------------------------------
Sub test()
Dim T(1 To 3)
T(1) = "Isabelle"
T(2) = "Nicole"
T(3) = "Sylvie"
For Each Elt In T
Call ValeurVariable(Elt)
Next
End Sub
'--------------------------------
Et dans le module1, cette procédure :
'--------------------------------
Sub ValeurVariable(V As Variant)
MsgBox V
End Sub
'--------------------------------
Et ça fonctionne très bien, sans anicroche!
Habituellement, on attribue le type variant à la variable Elt
dans une boucle d'un tableau, car le tableau peut prendre n'importe
quelle valeur.
L'utilisation des différents modules, c'est juste pour faire réaliser
qu'il n'y a pas une limite particulière à l'utilisation de cette variable.
Dans le haut du module2, déclaration de la variable Elt Dim Elt as Variant
Dans la feuille module de la feuil1, cette procédure :
'-------------------------------- Sub test()
Dim T(1 To 3)
T(1) = "Isabelle" T(2) = "Nicole" T(3) = "Sylvie"
For Each Elt In T Call ValeurVariable(Elt) Next End Sub '--------------------------------
Et dans le module1, cette procédure : '-------------------------------- Sub ValeurVariable(V As Variant) MsgBox V End Sub '--------------------------------
Et ça fonctionne très bien, sans anicroche!
Habituellement, on attribue le type variant à la variable Elt dans une boucle d'un tableau, car le tableau peut prendre n'importe quelle valeur.
L'utilisation des différents modules, c'est juste pour faire réaliser qu'il n'y a pas une limite particulière à l'utilisation de cette variable.
MichD
MichD
Tu devrais pouvoir t'en tirer!
En passant, l'appel de cette ligne de code : Call Seuls_Les_Classeurs_Modifiés(Tblo, Dest)
devrait se retrouver à la fin de la procédure Sub FoldersList() comme dernière ligne de code de la procédure.
Bon j'essaie de remettre les morceaux dans l'ordre...pour le moment, ca ne fonctionne pas... Je reviens vers toi si cela est possible... Merci !
mclain
Re bonsoir,
Bon, je n'obtiens pas ce que je voulais comme sous Excel 2003. J'ai X fichier excel comportant 1 seule feuille (quelque soit le nom). Je veux sous un nouveau fichier excel, lancer la macro qui me récupère et compile l'ensemble des données du fichier S1, S2, S3...dans une seule et même feuille dans le nouveau fichier.
Par exemple 10 fichiers de 3000 lignes... que je compile en une seule feuil le qui fait désormais 30 000 lignes.
Or la, la macro me rapatrie les données des x feuilles en x onglet...
Merci !
Re bonsoir,
Bon, je n'obtiens pas ce que je voulais comme sous Excel 2003.
J'ai X fichier excel comportant 1 seule feuille (quelque soit le nom).
Je veux sous un nouveau fichier excel, lancer la macro qui me récupère et compile l'ensemble des données du fichier S1, S2, S3...dans une seule et même feuille dans le nouveau fichier.
Par exemple 10 fichiers de 3000 lignes... que je compile en une seule feuil le qui fait désormais 30 000 lignes.
Or la, la macro me rapatrie les données des x feuilles en x onglet...
Bon, je n'obtiens pas ce que je voulais comme sous Excel 2003. J'ai X fichier excel comportant 1 seule feuille (quelque soit le nom). Je veux sous un nouveau fichier excel, lancer la macro qui me récupère et compile l'ensemble des données du fichier S1, S2, S3...dans une seule et même feuille dans le nouveau fichier.
Par exemple 10 fichiers de 3000 lignes... que je compile en une seule feuil le qui fait désormais 30 000 lignes.
Or la, la macro me rapatrie les données des x feuilles en x onglet...
Merci !
MichD
Au début de la procédure, une fenêtre s'ouvre pour te demander de lui indiquer le répertoire où sont logés les fichiers à traiter.
Attention aux coupures de lignes intempestives faites par le service de messagerie...
'---------------------------------------------------- Sub Compilation()
Dim Répertoire As String, Fichier As String Dim Sh As Worksheet, Wk As Workbook Dim DerLig As Long, DerCol As Long Dim LastRow As Variant, T As Variant Dim Message As String
'Choix du répertoire où sont les fichiers Répertoire = SelDossier(Répertoire) & ""
'Les données sont compilées dans la feuille compilation 'Fais disparaître le message d'alerte d'Excel concernant 'la suppression de la feuille Application.DisplayAlerts = False 'Supppression de la feuille si elle existe Worksheets("Compilation").Delete 'Remise en plage des alertes Application.DisplayAlerts = True 'Ajout d'une nouvelle feuille Set Sh = ThisWorkbook.Worksheets.Add 'Appellation de la nouvelle feuille Sh.Name = "Compilation"
'une boucle sur tous les fichiers du répertoire 'jusqu'au moment où le fichier est égale à "" Do While Fichier <> "" 's'assure de ne pas compiler les données du classeur qui reçoit 'les données de compilation. If LCase(ThisWorkbook.FullName) <> LCase(Répertoire & Fichier) Then With Sh 'Détermine la première ligne disponible dans la feuille compilation 'où les données doivent se copiées. Cette ligne de code supprime 'une erreur lorsqu'une feuille est totalement vide LastRow = .Cells.Find(What:="*", _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row + 1 'Si une erreur est générée à la ligne précédente If Err <> 0 Then 'efface l'erreur Err = 0 'La première ligne disponible est 1 LastRow = 1 End If End With
'ouverture du fichier Set Wk = Workbooks.Open(Répertoire & Fichier) 'Avec la feuille No1 peu importe son nom With Wk.Worksheets(1) 'teste si la feuille est pas vide ou non. If Application.CountA(.Cells) <> 0 Then 'Détermine la dernière de la feuille DerLig = .Cells.Find(What:="*", _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row 'Détermine la dernière colonne de la feuille DerCol = .Cells.Find(What:="*", _ LookIn:=xlValues, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious).Column
'Rg représente la plage à copier dans ma feuille compilation Set Rg = .Range("A1", .Cells(DerLig, DerCol))
'Plage les données de la plage dans un tableau afin de copier seulement 'les données et oublier les divers formats de la feuille source
With Rg 'Si la première ligne est 1, on doit alors copier 'les étiquettes de colonnes If LastRow = 1 Then T = Rg.Value Else 'Ce qui suit évite de copier les étiquettes de colonnes 'pour les autres fichiers... Set Rg = .Offset(1).Resize(.Rows.Count - 1) T = Rg.Value End If End With
'La copie se fait toujours à partir de la colonne A Sh.Range("A" & LastRow).Resize(UBound(T, 1), UBound(T, 2)).Value = T Else 'Si la première feuille est vide, on inscrit 'son nom dans la variable "message" Message = Message & Fichier & vbCrLf End If 'Fermeture du classeur sans sauvegarde Wk.Close False End With
'Appel du fichier suivant du répertoire Fichier = Dir() End If Loop
'Si la variable "Message" est différente de "", 'c'est qu'il y a des feuilles vides, et on indique 'le nom des classeurs à l'usager. If Message <> "" Then MsgBox "Ces fichiers n'ont aucune donnée sur leur première feuille." & _ vbCrLf & vbCrLf & Message End If End Sub
'---------------------------------------------------- Function SelDossier(Defaut As String) 'procédure pour définir le répertoire choisi par l'usager Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .InitialFileName = Defaut If .Show = -1 Then SelDossier = fd.SelectedItems(1) End If End With Set fd = Nothing End Function '----------------------------------------------------
Au début de la procédure, une fenêtre s'ouvre pour te
demander de lui indiquer le répertoire où sont logés
les fichiers à traiter.
Attention aux coupures de lignes intempestives faites par
le service de messagerie...
'----------------------------------------------------
Sub Compilation()
Dim Répertoire As String, Fichier As String
Dim Sh As Worksheet, Wk As Workbook
Dim DerLig As Long, DerCol As Long
Dim LastRow As Variant, T As Variant
Dim Message As String
'Choix du répertoire où sont les fichiers
Répertoire = SelDossier(Répertoire) & ""
'Les données sont compilées dans la feuille compilation
'Fais disparaître le message d'alerte d'Excel concernant
'la suppression de la feuille
Application.DisplayAlerts = False
'Supppression de la feuille si elle existe
Worksheets("Compilation").Delete
'Remise en plage des alertes
Application.DisplayAlerts = True
'Ajout d'une nouvelle feuille
Set Sh = ThisWorkbook.Worksheets.Add
'Appellation de la nouvelle feuille
Sh.Name = "Compilation"
'une boucle sur tous les fichiers du répertoire
'jusqu'au moment où le fichier est égale à ""
Do While Fichier <> ""
's'assure de ne pas compiler les données du classeur qui reçoit
'les données de compilation.
If LCase(ThisWorkbook.FullName) <> LCase(Répertoire & Fichier) Then
With Sh
'Détermine la première ligne disponible dans la feuille compilation
'où les données doivent se copiées. Cette ligne de code supprime
'une erreur lorsqu'une feuille est totalement vide
LastRow = .Cells.Find(What:="*", _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
'Si une erreur est générée à la ligne précédente
If Err <> 0 Then
'efface l'erreur
Err = 0
'La première ligne disponible est 1
LastRow = 1
End If
End With
'ouverture du fichier
Set Wk = Workbooks.Open(Répertoire & Fichier)
'Avec la feuille No1 peu importe son nom
With Wk.Worksheets(1)
'teste si la feuille est pas vide ou non.
If Application.CountA(.Cells) <> 0 Then
'Détermine la dernière de la feuille
DerLig = .Cells.Find(What:="*", _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'Détermine la dernière colonne de la feuille
DerCol = .Cells.Find(What:="*", _
LookIn:=xlValues, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
'Rg représente la plage à copier dans ma feuille compilation
Set Rg = .Range("A1", .Cells(DerLig, DerCol))
'Plage les données de la plage dans un tableau afin de
copier seulement
'les données et oublier les divers formats de la feuille source
With Rg
'Si la première ligne est 1, on doit alors copier
'les étiquettes de colonnes
If LastRow = 1 Then
T = Rg.Value
Else
'Ce qui suit évite de copier les étiquettes de colonnes
'pour les autres fichiers...
Set Rg = .Offset(1).Resize(.Rows.Count - 1)
T = Rg.Value
End If
End With
'La copie se fait toujours à partir de la colonne A
Sh.Range("A" & LastRow).Resize(UBound(T, 1), UBound(T,
2)).Value = T
Else
'Si la première feuille est vide, on inscrit
'son nom dans la variable "message"
Message = Message & Fichier & vbCrLf
End If
'Fermeture du classeur sans sauvegarde
Wk.Close False
End With
'Appel du fichier suivant du répertoire
Fichier = Dir()
End If
Loop
'Si la variable "Message" est différente de "",
'c'est qu'il y a des feuilles vides, et on indique
'le nom des classeurs à l'usager.
If Message <> "" Then
MsgBox "Ces fichiers n'ont aucune donnée sur leur première
feuille." & _
vbCrLf & vbCrLf & Message
End If
End Sub
'----------------------------------------------------
Function SelDossier(Defaut As String)
'procédure pour définir le répertoire choisi par l'usager
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.InitialFileName = Defaut
If .Show = -1 Then
SelDossier = fd.SelectedItems(1)
End If
End With
Set fd = Nothing
End Function
'----------------------------------------------------
Au début de la procédure, une fenêtre s'ouvre pour te demander de lui indiquer le répertoire où sont logés les fichiers à traiter.
Attention aux coupures de lignes intempestives faites par le service de messagerie...
'---------------------------------------------------- Sub Compilation()
Dim Répertoire As String, Fichier As String Dim Sh As Worksheet, Wk As Workbook Dim DerLig As Long, DerCol As Long Dim LastRow As Variant, T As Variant Dim Message As String
'Choix du répertoire où sont les fichiers Répertoire = SelDossier(Répertoire) & ""
'Les données sont compilées dans la feuille compilation 'Fais disparaître le message d'alerte d'Excel concernant 'la suppression de la feuille Application.DisplayAlerts = False 'Supppression de la feuille si elle existe Worksheets("Compilation").Delete 'Remise en plage des alertes Application.DisplayAlerts = True 'Ajout d'une nouvelle feuille Set Sh = ThisWorkbook.Worksheets.Add 'Appellation de la nouvelle feuille Sh.Name = "Compilation"
'une boucle sur tous les fichiers du répertoire 'jusqu'au moment où le fichier est égale à "" Do While Fichier <> "" 's'assure de ne pas compiler les données du classeur qui reçoit 'les données de compilation. If LCase(ThisWorkbook.FullName) <> LCase(Répertoire & Fichier) Then With Sh 'Détermine la première ligne disponible dans la feuille compilation 'où les données doivent se copiées. Cette ligne de code supprime 'une erreur lorsqu'une feuille est totalement vide LastRow = .Cells.Find(What:="*", _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row + 1 'Si une erreur est générée à la ligne précédente If Err <> 0 Then 'efface l'erreur Err = 0 'La première ligne disponible est 1 LastRow = 1 End If End With
'ouverture du fichier Set Wk = Workbooks.Open(Répertoire & Fichier) 'Avec la feuille No1 peu importe son nom With Wk.Worksheets(1) 'teste si la feuille est pas vide ou non. If Application.CountA(.Cells) <> 0 Then 'Détermine la dernière de la feuille DerLig = .Cells.Find(What:="*", _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row 'Détermine la dernière colonne de la feuille DerCol = .Cells.Find(What:="*", _ LookIn:=xlValues, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious).Column
'Rg représente la plage à copier dans ma feuille compilation Set Rg = .Range("A1", .Cells(DerLig, DerCol))
'Plage les données de la plage dans un tableau afin de copier seulement 'les données et oublier les divers formats de la feuille source
With Rg 'Si la première ligne est 1, on doit alors copier 'les étiquettes de colonnes If LastRow = 1 Then T = Rg.Value Else 'Ce qui suit évite de copier les étiquettes de colonnes 'pour les autres fichiers... Set Rg = .Offset(1).Resize(.Rows.Count - 1) T = Rg.Value End If End With
'La copie se fait toujours à partir de la colonne A Sh.Range("A" & LastRow).Resize(UBound(T, 1), UBound(T, 2)).Value = T Else 'Si la première feuille est vide, on inscrit 'son nom dans la variable "message" Message = Message & Fichier & vbCrLf End If 'Fermeture du classeur sans sauvegarde Wk.Close False End With
'Appel du fichier suivant du répertoire Fichier = Dir() End If Loop
'Si la variable "Message" est différente de "", 'c'est qu'il y a des feuilles vides, et on indique 'le nom des classeurs à l'usager. If Message <> "" Then MsgBox "Ces fichiers n'ont aucune donnée sur leur première feuille." & _ vbCrLf & vbCrLf & Message End If End Sub
'---------------------------------------------------- Function SelDossier(Defaut As String) 'procédure pour définir le répertoire choisi par l'usager Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .InitialFileName = Defaut If .Show = -1 Then SelDossier = fd.SelectedItems(1) End If End With Set fd = Nothing End Function '----------------------------------------------------
