transferts de valeur d'un dossier vers un excel

[pago82]

bonjour a tous

je viens vers vous car je suis une bille en vba .

j'aurai besoin de récupérer la case M2 et le résultat d une formule situer en N1 dont la valeur est de type horaire "00:00:00" de chaque classeur d'un même dossier et de la copier dans un classeur de ce même dossier sous une colonne C et D
C4 = M2 classeur 1 D4 = N1 classeur 1
C5 = M2 classeur 2 D4 = N1 classeur 2
.....
le tous autant de fois que de classeur

le seul classeur non pris en compte seras celui ou sont copier les valeurs M2 et N1
j'avais commencé a essayer de modifier un vieux bout de code mais cela manque de commentaire

    Sub Transferer()
    Dim dossier As Object, Fichier As Object, Chemin As String, Lg As Integer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
    DerLg = Range("D65536").End(xlUp).Row + 1
    Range("D3:D" & DerLg).Delete
    Chemin = ThisWorkbook.Path
    FName = Dir(Chemin & "\" & "*.xls")
    Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
    Lg = 3
    For Each Fichier In dossier.Files
    NomFichier = Fichier.Name
    If Not Fichier.Name = "Analytique OGP HEURE SUP.xls" Then
    Workbooks.Open Filename:=Chemin & "/" & NomFichier
    On Error Resume Next
           
    With Workbooks(NomFichier)
    .Sheets("Feuil1").Range("N1").Copy ThisWorkbook.Sheets("HEURE SUP").Range("D" & Lg)
    .Close
    Lg = Lg + 1
    End With
    End If
    Next
    End Sub

en espèrent que quelqu'un est un peut de temps pour m'aider;

merci d'avance
cordialement
PAGO82

 

[camarchepas]

Re : transferts de valeur d'un dossier vers un excel

Bonjour ,

Pour le test , copie de ce fichier dans le dossier à traiter,

pour les tests commencer avec 2 ou 3 fichiers

Ensuite un appuis sur le sourire et hop

J'ai supposé que la feuille à traiter était celle active puisque pas précisé.


voilà

Option Explicit

Sub Rassemble()
Dim Dossier As String
Dim Fichier  As String
Dim Ligne As Long
'Définit le dossier source
'Dossier = " C:\Dossiers\relevées\"
'Si le classeur contenant la macro est dans le même dossier cela peut s'écrire
Dossier = ThisWorkbook.Path & "\"

'Initialise la lecture du dossier
Fichier = Dir(Dossier & "*.xls")

'1er ligne cible
Ligne = 4
'Boucle de scrutation dossier
Do
 'Si pas le classeur de synthése
 If Fichier <> ThisWorkbook.Name Then
  'Ouverture du fichier
   Workbooks.Open Dossier & Fichier

     'Transfert M2 vers Cxx avec forçage du format date
      ThisWorkbook.Sheets("Feuil1").Range("C" & Ligne) = Workbooks(Fichier).ActiveSheet.Range("M2")
     'Transfert de N1 vers Dxx avec forçage du format date
      ThisWorkbook.Sheets("Feuil1").Range("D" & Ligne) = Workbooks(Fichier).ActiveSheet.Range("N1")

    'Increment de ligne pour la prochaine écriture
     Ligne = Ligne + 1
  'Fermeture du fichier sans sauvegarde
   Workbooks(Fichier).Close False
 End If
 'lecture fichier suivant
 Fichier = Dir
'Si encore fichier reboucle sur le do
Loop Until Fichier = ""
End Sub