Parcourir des fichiers excel

Question

Bonsoir ; 

Svp j'ai besoin de votre aide je veux parcourir plusieurs fichiers excel sachant que chque fichiers a une sheet qui s'appele statusrepport et je veux copier de chaque fichiers à partir de ligne jusqu'a la derniére ligne et je vais les coller sur un fichier excel TL à partir de ligne D27 c'est un peu compliqué mais j'ai confiance en vous j'ai essayé ce code mais il traite un seul fi chier et merci d'avance 

Imports Microsoft.Office.Interop.Excel
Imports Microsoft.Office.Interop

Public Class Form1

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim Système As Object           'Système de fichiers  
        Dim Dossier As Object           'Répertoire  
        Dim Fichiers As Object          'Collection de fichiers du répertoire  
        Dim Fichier As Object           'Fichier (élément de la collection Fichiers)  
        Dim Nom_Dossier As String       'Nom du répertoire  
        Dim Nom_Fichier As String       'Nom du fichier  
        Dim xlWorkBook, xlWorkBook2 As Excel.Workbook
        Dim xlWsheet2 As Excel.Worksheet
        Dim xlApp As New Excel.Application
        xlApp.Visible = True
        'Lecture du répertoire 
        Nom_Dossier = "C:\Users\sarra.arfaoui\Desktop\test 1"
        Système = CreateObject("Scripting.FileSystemObject")
        Dossier = Système.GetFolder(Nom_Dossier)
        Fichiers = Dossier.Files
        xlWorkBook2 = xlApp.Workbooks.Open("C:\Users\sarra.arfaoui\Desktop\test 1\ss\Template TL Status Report V2.0.xlsx")
        xlWsheet2 = xlWorkBook2.Sheets("Status Report")
       
        'Contrôler chaque fichier du répertoire 
        For Each Fichier In Fichiers
            '- Vérifier s'il s'agit d'un fichier Excel... 

            '... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons 
            Nom_Fichier = Nom_Dossier & "\" & Fichier.Name
            xlWorkBook = xlApp.Workbooks.Open(Filename:=Nom_Fichier, UpdateLinks:=XlUpdateLinks.xlUpdateLinksAlways)


          
            Dim DernLigne As Long
            DernLigne = xlWorkBook.Sheets("StatusReport").Range("D" & xlWorkBook.Sheets("StatusReport").Rows.Count).End(XlDirection.xlUp).Row


            xlWorkBook.Sheets("StatusReport").Range("D25:K" & DernLigne).Copy( _
            Destination:=xlWsheet2.Range("D27"))
            Dim DernLigne3 As Long
            DernLigne3 = xlWsheet2.Range("D" & xlWsheet2.Rows.Count).End(XlDirection.xlUp).Row
            While (xlWsheet2.Range("D" & (DernLigne3)).Text <> "")
                xlWorkBook.Sheets("StatusReport").Range("D25:K" & DernLigne).Copy( _
                Destination:=xlWsheet2.Range("D" & (DernLigne3)))

            End While


            xlWorkBook2.SaveAs(Filename:="C:\Users\sarra.arfaoui\Desktop\test 1\ss\TL.xlsx")
            xlWorkBook.Close()
            xlWorkBook2.Close()
        Next Fichier

        xlApp.Quit()
    End Sub
End Class

Cordialement; 

Answer 1

Bonjour sarraarfaoui

Si je comprends bien vous copiez toujours dans le même endroit avec :
     xlWorkBook.Sheets("StatusReport").Range("D25:K" & DernLigne).Copy( _
            Destination:=xlWsheet2.Range("D27"))
Donc chaque ficher sur écrit les autres.

En plus je ne vois plus la logique d'avoir le WHILE

Je dirais d’utiliser simplement :

DernLigne3 = xlWsheet2.Range("D" & xlWsheet2.Rows.Count).End(XlDirection.xlUp).Row
     xlWorkBook.Sheets("StatusReport").Range("D25:K" & DernLigne).Copy( _
            Destination:=xlWsheet2.Range("D" & DernLigne3))

Cordialement,

---

Aurel BERA, MSFT
MSDN Community Support. LE CONTENU EST FOURNI "TEL QUEL" SANS GARANTIE D'AUCUNE SORTE, EXPLICITE OU IMPLICITE.
S'il vous plaît n'oubliez pas de "Marquer comme réponse" les réponses qui ont résolu votre problème. C'est une voie commune pour reconnaître ceux qui vous ont aidé, et rend plus facile pour les autres visiteurs de trouver plus tard la résolution.

Answer 2

Bonjour 

Pour Corriger j'ai essayé ce code 

Public Class Form1

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim Système As Object           'Système de fichiers  
        Dim Dossier As Object           'Répertoire  
        Dim Fichiers As Object          'Collection de fichiers du répertoire  
        Dim Fichier As Object           'Fichier (élément de la collection Fichiers)  
        Dim Nom_Dossier As String       'Nom du répertoire  
        Dim Nom_Fichier As String       'Nom du fichier  
        Dim xlWorkBook, xlWorkBook2 As Excel.Workbook
        Dim xlWsheet2 As Excel.Worksheet
        Dim xlApp As New Excel.Application
        xlApp.Visible = True
        'Lecture du répertoire 
        Nom_Dossier = "C:\Users\sarra.arfaoui\Desktop\test 1"
        Système = CreateObject("Scripting.FileSystemObject")
        Dossier = Système.GetFolder(Nom_Dossier)
        Fichiers = Dossier.Files

        xlWorkBook2 = xlApp.Workbooks.Open("C:\Users\sarra.arfaoui\Desktop\test 1\Sarra\Template TL Status Report V2.0.xlsx")
        xlWsheet2 = xlWorkBook2.Sheets("Status Report")
        For Each Fichier In Fichiers
      
            Nom_Fichier = Nom_Dossier & "\" & Fichier.Name
            xlWorkBook = xlApp.Workbooks.Open(Filename:=Nom_Fichier, UpdateLinks:=XlUpdateLinks.xlUpdateLinksAlways)

            Dim DernLigne As Long
            DernLigne = xlWorkBook.Sheets("StatusReport").Range("D" & xlWorkBook.Sheets("StatusReport").Rows.Count).End(XlDirection.xlUp).Row


            Dim DernLigne3 As Long
            DernLigne3 = xlWsheet2.Range("Q" & xlWsheet2.Rows.Count).End(XlDirection.xlUp).Row


            xlWorkBook.Sheets("StatusReport").Range("D25:K" & DernLigne).Copy( _
                   Destination:=xlWsheet2.Range("D" & DernLigne3 + 1))
        Next Fichier
        xlApp.Quit()
    End Sub
End Class

mais je pense qu'il est entrain de copier à partir de le meme range or que je cherche qui seront copiés l'un dernier l'autre 

Merci pour votre précieuse aide 

Answer 3

Bonjour

Il copie à partir de DernLigne3  qui normalement c'est à la fin du Sheet. Utilisez le debugger pour voir les valeurs
de DernLigne3.

Cordialement,

---

Aurel BERA, MSFT
MSDN Community Support. LE CONTENU EST FOURNI "TEL QUEL" SANS GARANTIE D'AUCUNE SORTE, EXPLICITE OU IMPLICITE.
S'il vous plaît n'oubliez pas de "Marquer comme réponse" les réponses qui ont résolu votre problème. C'est une voie commune pour reconnaître ceux qui vous ont aidé, et rend plus facile pour les autres visiteurs de trouver plus tard la résolution.

Answer 4

Bonjour

Avez-vous des nouvelles pour nous?

Merci!

Cordialement,

---

Aurel BERA, MSFT
MSDN Community Support. LE CONTENU EST FOURNI "TEL QUEL" SANS GARANTIE D'AUCUNE SORTE, EXPLICITE OU IMPLICITE.
S'il vous plaît n'oubliez pas de "Marquer comme réponse" les réponses qui ont résolu votre problème. C'est une voie commune pour reconnaître ceux qui vous ont aidé, et rend plus facile pour les autres visiteurs de trouver plus tard la résolution.

Answer 5

J'ai utiliser cut je les deplacer vers la position souhaitée

  Dim DernLigne4 As Long
        DernLigne4 = xlWsheet2.Range("K" & xlWsheet2.Rows.Count).End(XlDirection.xlUp).Row
       
        xlWsheet2.Range("D" & DernLigne5 + 1 & ":L" & DernLigne4).Cut(xlWsheet2.Range("D27"))