introduire des données ds un classeur

[hugo76]

Bonjour à tous,

Je fais appel à votre aide car je n'arrive pas à faire la macro que je souhaiterais.
le but serait de collecter et copier les cellules F14 à F28 de l'onglet "REPORT" des fichiers qui seront dans un dossier commun.
Créer une feuille de synthèse qui regroupe les fichiers en fait!
pour l'instant j'ai le choix du dossier mais je cale pour l'import des cellules F14 à F28 pour les restituer dans les cellules du classeur (F8; F22 pour le fichier1 G8 à G22 pour fichier 2 etc..)
Merci d'avance.



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

 

[Staple1600]

Re : introduire des données ds un classeur

Bonsoir hugo76 , le fil, le forum


Ça fonctionne (sur Excel 2000)

Pour tester , lancer la macro: TEST

Option Explicit

Sub TEST()
Application.ScreenUpdating = False
GrouperDataFichiers
Application.ScreenUpdating = True
End Sub

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

Private Sub GrouperDataFichiers()
Dim FSO, SourceFolder, FileItem, chemin$, T()
Dim cpt&, WB As Workbook
Dim DEST As Worksheet: Set DEST = ThisWorkbook.Sheets(1)

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 Split(FileItem.Name, ".")(1) = "xls" Then
If Not FileItem.Name Like "Classeur1.xls" Then
cpt& = cpt& + 1
    Set WB = Workbooks.Open(chemin$ & "\" & FileItem.Name)
    With WB
    .Sheets(1).Range("F14:F28").Copy DEST.[F8].Offset(, cpt& - 1)
    .Saved = True
    .Close
    End With
End If
End If
Next FileItem

Set WB = Nothing: Set DEST = Nothing
Set FileItem = Nothing: Set SourceFolder = Nothing
Set FSO = Nothing:
End Sub