Re : regrouper des données de plusieurs fichiers (macros?)
Bonjour le forum
,
PMO2 : Félicitation : efficacité, clarté, pédagogie, politesse, ça fait plaisir de voir des gens comme toi rejoindre le forum (j'ai vu un certain nombre de tes posts).
Une alternative au problème de modification de l'onglet, attaquer la feuille par le CodeName au lieu du Name (il y a peu de chance qu'il ai été changé).
Bonne journée
bonjour,
Tout d'abord merci pour l'explication précédente qui m'a permis de débuter et de comprendre un minimum le fonctionnement de la macro.
Je tombe sur 2 "hic" :
1/J'ai actuellement le même type de problème. Mais fichier on est onglet incrémentaux "Name 1","Name 2",... et la commande quoté ne veut pas passer
2/Je n'y ai pas encore reflechi mais chaque fichiers à un nombre variable de lignes et je souhaiterais qu'elles soient toutes intégrées
Je pense que la solution doit être dans le code en gras d'après ce que vous avez expliqué plus tôt
merci d'avance
Arnaud
voici une version "épurée"
Option Explicit
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("COMPETENCES MANAGERIALES")
For i& = 0 To 10
Info(1, 1 + i&) = S.Range(S.Cells(10, 5 + i&), _
S.Cells(10, 5 + 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("ANNEE", "MOIS", "JOUR" _
, "DOMAINE", "ACHETEUR", "CL", "CODE_FNR" _
, "ARTICLE", "CLAS_ACHET" _
, "EN-CDE", "CLASSE_SYST")
With DEST
.Range(.Cells(1, 1), .Cells(1, UBound(var) + 1)) = var
End With
Application.ScreenUpdating = False
Exit Sub
Erreur:
Application.ScreenUpdating = False
MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub