Compilation fichiers sous Excel 2003 ne fonctionne plus sous Excel 2013

Le
mclain
Bonsoir à tous,

J'utilisais jusqu'ici un petit script excel 2003 qui me servait à compile=
r différents fichiers excel sous une seule et même feuille.

Or nous venons de migrer en 2013.
Du coup j'ai une erreur que je n'arrive pas à résoudre.

Je pense ne pas être le seul à l'utiliser.
Voici le script

Erreur compilation
Verifiez et mettez à jour les instructions Declare, puis marquez-les avec=
l'attribut PtrSafe

J'espère que vous pourrez m'aider car je ne vois pas
mes compétences sont bien trop limitées.

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

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260

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è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 exclu=
es 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:=msoSortOrderD=
escending) > 0 Then
For i = 1 To .FoundFiles.Count ' recherche fichiers
chemin = .FoundFiles(i) ' chemin fichiers
If chemin <> book Then ' différent du classeur regroupan=
t
Workbooks.Open chemin, 0 ' 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 & " [" & Sheet=
s(k).Name & "]"
' If ligne > 2 Then l = 3 Else l = 1 ' une seule fo=
is 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 " & l=
igne & " 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
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
MichD
Le #26395831
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


Et que la chance soit avec toi!
;-))

MichD
mclain
Le #26395834
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
MichD
Le #26395843
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
Le #26395846
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
mclain
Le #26395849
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
MichD
Le #26395863
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
MichD
Le #26395868
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.

Call FoldersInFolder(répertoireSource, RépertoireDestination)
Call Seuls_Les_Classeurs_Modifiés(Tblo, RépertoireDestination)


Salutations.

MichD
mclain
Le #26395921
Bonsoir Mich D, Isabelle,

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
Le #26395933
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 !
MichD
Le #26396080
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) & ""

Fichier = Dir(Répertoire & "*.xl*")

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next

'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

Application.ScreenUpdating = True
Application.EnableEvents = True

'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
'----------------------------------------------------
Publicité
Poster une réponse
Anonyme