Extraction de données dans divers fichiers xls d'un même dossier

Ju33 -  
cs_Le Pivert Messages postés 8437 Statut Contributeur -
Bonjour,

Je suis en train de faire une macro sous Excel 2016. Je suis novice et rencontre quelques difficultés pour "finaliser" le projet….

Voici le code à l'instant T :

Sub ESSAI1()

Dim wkA As Workbook, wkB As Workbook
Dim chemin As String, fichier As String
Dim j As Long

Application.ScreenUpdating = False 'gagner en temps d'execution
Set wkA = ThisWorkbook 'le dossier qui va recevoir les donn?es
chemin = "C:\Users\T0159962\Desktop\Direction Technique\Devis Ingenierie\" 'adresse commun pour les deux dossiers sources
'******************************* Copier donnees Classeur A
fichier = "TDMSFR1268093-00 - FPV - SPGE - FT287 rev 00" 'Nom du classeur 1
Workbooks.Open chemin & fichier & ".xlsm" 'ouvrir classeur1
Set wkB = ActiveWorkbook
j = 2
wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)

wkB.Close True

j = wkA.Sheets("Suividevis").Range("A" & Rows.Count).End(xlUp).Row

'******************************* Copier donnees Classeur B
fichier = "TDMSFR1266422-03- ATL2 - FPV ISTS Iguane"
Workbooks.Open chemin & fichier & ".xlsm"
Set wkB = ActiveWorkbook
wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)

wkB.Close True

Application.ScreenUpdating = True

End Sub

Voici les problèmes rencontrés :
-Au lieu de mettre les informations dans la ligne en dessous de la première pour le fichier A, cela me met les informations dans la ligne au dessus…. Cela modifie donc le nom de mes colonnes… au lieu d'ajouter les informations à la suite.

-Il faudrait que cela me copie la valeur de la cellule source et non la formule qui y est insérée.

-La mise en forme du fichier source est conservée lors du copiage, cependant j'aimerais que ce soit la mise en forme du fichier de synthèse qui soit appliquée.

-Et pour finir, mon code sera parfait lorsque j'aurais inséré une boucle qui dit "ouvrir un à un les fichier du répertoire XXX, pour effectuer le copié collé" .. Pour l'instant la macro ne traite que 2 fichiers…

MERCI par avance pour votre aide précieuse!
Ju

Configuration: Windows / Edge 18.17763

2 réponses

  1.
    cs_Le Pivert Messages postés 8437 Statut Contributeur 730
     
    Bonjour, 

    j = wkA.Sheets("Suividevis").Range("A" & Rows.Count).End(xlUp).Row


    te donne la dernière ligne renseignée. Il faut donc ajouter une ligne pour avoir la 1ère ligne vide.
    Comme ceci: 

    j = wkA.Sheets("Suividevis").Range("A" & Rows.Count).End(xlUp).Row + 1


    1
    1. Ju33
       
      Merci pour le retour,
      Après modification, la macro a une erreur, elle m'indique 2 fois les résultats du second fichier l'un en dessous de l'autre et n'affiche plus le résultat du fichier A :

      Sub ESSAI1()

      Dim wkA As Workbook, wkB As Workbook
      Dim chemin As String, fichier As String
      Dim j As Long

      Application.ScreenUpdating = False 'gagner en temps d'execution
      Set wkA = ThisWorkbook 'le dossier qui va recevoir les donn?es
      chemin = "C:\Users\T0159962\Desktop\Direction Technique\Devis Ingenierie\" 'adresse commun pour les deux dossiers sources
      '******************************* Copier donnees Classeur A
      fichier = "TDMSFR1268093-00 - FPV - SPGE - FT287 rev 00" 'Nom du classeur 1
      Workbooks.Open chemin & fichier & ".xlsm" 'ouvrir classeur1
      Set wkB = ActiveWorkbook

      j = 2
      wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
      wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
      wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
      wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
      wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
      wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
      wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
      wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
      wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
      wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)

      wkB.Close True

      j = wkA.Sheets("Suividevis").Range("A" & Rows.Count).End(xlUp).Row + 1

      '******************************* Copier donnees Classeur B
      fichier = "TDMSFR1266422-03- ATL2 - FPV ISTS Iguane"
      Workbooks.Open chemin & fichier & ".xlsm"
      Set wkB = ActiveWorkbook
      wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
      wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
      wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
      wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
      wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
      wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
      wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
      wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
      wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
      wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)

      wkB.Close True

      Application.ScreenUpdating = True

      End Sub

      Voyez vous le problème ?
      0
    2. cs_Le Pivert Messages postés 8437 Statut Contributeur 730
       
      regarde cela pour parcourir un répertoire:

      https://vbaforexcel.wordpress.com/2013/09/06/lister-les-fichiers-et-sous-dossiers-dun-dossier/

      elle m'indique 2 fois les résultats du second fichier l'un en dessous de l'autre :

      c'est normal, tu as mis 2 fois la même chose: 

      wkB.Worksheets("Contexte").Range("L17").Copy wkA.Sheets("Suividevis").Cells(j, 3)
wkB.Worksheets("Contexte").Range("E12").Copy wkA.Sheets("Suividevis").Cells(j, 4)
wkB.Worksheets("Contexte").Range("F2").Copy wkA.Sheets("Suividevis").Cells(j, 5)
wkB.Worksheets("Contexte").Range("I7").Copy wkA.Sheets("Suividevis").Cells(j, 6)
wkB.Worksheets("Contexte").Range("I5").Copy wkA.Sheets("Suividevis").Cells(j, 7)
wkB.Worksheets("Contexte").Range("H12").Copy wkA.Sheets("Suividevis").Cells(j, 8)
wkB.Worksheets("Contexte").Range("O2").Copy wkA.Sheets("Suividevis").Cells(j, 9)
wkB.Worksheets("Contexte").Range("C18").Copy wkA.Sheets("Suividevis").Cells(j, 11)
wkB.Worksheets("Contexte").Range("D19").Copy wkA.Sheets("Suividevis").Cells(j, 12)
wkB.Worksheets("Contexte").Range("K13").Copy wkA.Sheets("Suividevis").Cells(j, 13)


      Voilà
      0
  2. Ju33
     
    Bonjour,

    J'ai abouti quant à mon besoin, j'ai seulement un problème qui persiste...

    J'avais essayé "Application.DisplayAlerts = False/True" pour empêcher les pop-ups de s'ouvrir mais cela ne fonctionne pas…

    En fait c'est une fenêtre d'alerte indiquant que le fichier est à la dernière version existante, qui s'ouvre à l'ouverture de chaque fichier source… Or il y a 50 fichiers source, cela demande de rester derrière le PC et cliquer sur "OK" toutes les 5 secondes. Très gênant.

    Avez-vous une solution ?

    Merci
    Ju
    0
    1. cs_Le Pivert Messages postés 8437 Statut Contributeur 730
       
      L'as-tu mis juste avant d'ouvrir chaque fichier comme cela? 

      For Each fichier In dossier.Files
    If fichier = ThisWorkbook.Path & "\" & ThisWorkbook.Name Then 'chemin classeur reception
    Else
   Application.DisplayAlerts = False
 Set wb = Workbooks.Open(fichier)


      Si le message persiste il faudrait voir dans les options d'Excel.

      Ce n'est pas une version limitée?

      @+
      0