Bonjour,
Débutant dans le VBA, je cherche à consolider des fichiers excel.
Je vois que le problème a déjà été posé des centaines de fois, et pour des raisons que j'ignore, la plupart des codes ne fonctionnent pas du tout. Néanmoins en cherchant des informations je suis tombé sur ce topic https://www.excel-downloads.com/threads/regrouper-des-donnees-de-plusieurs-fichiers-macros.110095/
où vous PMO2 a développé une macro afin de grouper des fichiers qui fonctionne (dans l'exemple en tout cas).
J'ai essayé de l'utiliser mais elle ne fonctionne que pour des fichiers excel 97-2003. Quand j'essaye de l'appliquer à des nouveaux fichiers excel il y a une erreur et la ligne
est surlignée.
Y a t-il un moyen de l'adapter afin qu'elle soit utilisable pour des fichiers excel récents ?
Bonne journée,
Etienne.
Débutant dans le VBA, je cherche à consolider des fichiers excel.
Je vois que le problème a déjà été posé des centaines de fois, et pour des raisons que j'ignore, la plupart des codes ne fonctionnent pas du tout. Néanmoins en cherchant des informations je suis tombé sur ce topic https://www.excel-downloads.com/threads/regrouper-des-donnees-de-plusieurs-fichiers-macros.110095/
où vous PMO2 a développé une macro afin de grouper des fichiers qui fonctionne (dans l'exemple en tout cas).
Code:
Private Function ChoisirDossier() As String
Dim objShell
Dim objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder _
(&H0&, "Sélectionnez un Dossier", &H1&)
On Error GoTo Erreur
ChoisirDossier = objFolder.ParentFolder _
.ParseName(objFolder.Title).Path & ""
Exit Function
Erreur:
ChoisirDossier = ""
End Function
Sub GrouperDataFichiers()
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim chemin$
Dim T()
Dim cpt&
Dim g&
Dim i&
Dim j&
Dim Lig&
Dim var
Dim WB As Workbook
Dim S As Worksheet
Dim DEST As Worksheet
Dim Info(1 To 1, 1 To 26)
'------------
chemin$ = ChoisirDossier
If chemin$ = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(chemin$)
If SourceFolder.Files.Count = 0 Then Exit Sub
For Each FileItem In SourceFolder.Files
If LCase(Right(FileItem.Name, 4)) = ".xls" Then
cpt& = cpt& + 1
ReDim Preserve T(1 To cpt&)
T(cpt&) = chemin$ & "\" & FileItem.Name
End If
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
'------------
Application.ScreenUpdating = False
Set DEST = Sheets.Add
Lig& = 1
For g& = 1 To UBound(T)
Set WB = GetObject(T(g&))
Set S = WB.Sheets("IBP")
Info(1, 1) = S.Range("c4")
Info(1, 2) = S.Range("h12")
var = Array("", "b", "c", "f")
For j& = 1 To 3
For i& = 20 To 18 Step -1
If S.Range(var(j&) & i&) <> "" Then
Info(1, 2 + j&) = S.Range(var(j&) & i&)
Exit For
End If
Next i&
Next j&
Set S = WB.Sheets("TRES")
Info(1, 6) = S.Range("D10")
For i& = 5 To 14
Info(1, 2 + i&) = S.Range(S.Cells(10, i&), _
S.Cells(10, i&))
Info(1, 12 + i&) = S.Range(S.Cells(11, i&), _
S.Cells(11, i&))
Next i&
WB.Close
Set WB = Nothing
Lig& = Lig& + 1
DEST.Range(DEST.Cells(Lig&, 1), _
DEST.Cells(Lig&, UBound(Info, 2))) = Info
Erase Info
Next g&
var = Array("Nom/prénom", "choix 3e année", "lieu dernier stage" _
, "entreprise dernier stage", "fonction", "secteur", "Leadership" _
, "Teamwork", "Interpersonal Awareness / People skills" _
, "Communication skills", "Technical & Business Knowledge" _
, "Analytical skills", "Results orientation & Drive" _
, "Self awareness / Personnal effectiveness", "Ability to Learn & Grow" _
, "Creativity & Innovation", "Leadership", "Teamwork" _
, "Interpersonal Awareness / People skills", "Communication skills" _
, "Technical & Business Knowledge", "Analytical skills" _
, "Results orientation & Drive", "Self awareness / Personnal effectiveness" _
, "Ability to Learn & Grow", "Creativity & Innovation")
With DEST
.Range(.Cells(1, 1), .Cells(1, UBound(var) + 1)) = var
.Range("a1").Interior.ColorIndex = 6
.Range("b1:f1").Interior.ColorIndex = 45
.Range("g1:p1").Interior.ColorIndex = 3
.Range("q1:z1").Interior.ColorIndex = 39
End With
Application.ScreenUpdating = False
Exit Sub
Erreur:
Application.ScreenUpdating = False
MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End SubJ'ai essayé de l'utiliser mais elle ne fonctionne que pour des fichiers excel 97-2003. Quand j'essaye de l'appliquer à des nouveaux fichiers excel il y a une erreur et la ligne
Code:
For g& = 1 To UBound(T)Y a t-il un moyen de l'adapter afin qu'elle soit utilisable pour des fichiers excel récents ?
Bonne journée,
Etienne.
