Aide VBA

Bonjour

Je n'arrive pas a faire marcher cette macro comme je le veux

Sub Ouvrir_Fichiers()

' Permet d'ouvrir plusieurs fichiers dans un répertoire

' GC Excel - 2011-11-16

Dim wb As Workbook, wb2 As Workbook, wb3 As Workbook

Dim sPath As String, sFilename As String

Dim NbRows As Integer, rg As Range

Set wb = ThisWorkbook

Application.ScreenUpdating = False

sPath = "C:\Users\Utilisateur\Desktop\Suivi Véolia\RT a traiter\" 'Répertoire

sFilename = Dir(sPath & "*.xls*") 'ouvre tous les fichiers .xls*

Do While Len(sFilename) > 0

Set wb2 = Workbooks.Open(sPath & sFilename) 'Ouvre le fichier

'

' Votre code ici

Set wb3 = Workbooks.Open(ThisWorkbook.Path & "\" & "Global" & "\" & "RT 2017.xlsx")

'Essais ligne par ligne ca marche mais les lignes pourraient être décalé et ca me l'amene Ligne 2 a chaque fois

wb2.Sheets("Feuil2").Range("A2:A500").Copy wb3.Sheets("RT").Range("A1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("G2:G500").Copy wb3.Sheets("RT").Range("B1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("J2:J500").Copy wb3.Sheets("RT").Range("C1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("K2:K500").Copy wb3.Sheets("RT").Range("D1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("L2:L500").Copy wb3.Sheets("RT").Range("E1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("V2:V500").Copy wb3.Sheets("RT").Range("F1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("X2:X500").Copy wb3.Sheets("RT").Range("G1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("Y2:Y500").Copy wb3.Sheets("RT").Range("H1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("Z2:Z500").Copy wb3.Sheets("RT").Range("I1").End(xlUp)(2)

wb2.Sheets("Feuil2").Range("AB2:AB500").Copy wb3.Sheets("RT").Range("J1").End(xlUp)(2)

'Essais avec UNION mais ca ne marche pas

With wb2.Sheets("Feuil2")

Union(Range("A2:A500"), Range("G2:G500"), Range("J2:J500"), Range("K2:K500"), Range("L2:L500"), Range("V2:V500"), Range("X2:X500"), Range("Y2:Y500"), Range("Z2:Z500"), Range("AB2:AB500")).Copy _

wb3.Sheets("RT").Range("A").End(xlUp)(2)

End With

wb2.Close 'Fermer le fichier

sFilename = Dir

Loop

Application.ScreenUpdating = True

End Sub

A la fin j'ai fais deux essais de l'action que j'ai voulu faire autrement dit: Colle les colonne séléctionnées à la suite de celle placées les semaines précedentes. Une fonctionne mais peut me les décaller lors du collage et me les colles toujours en deuxieme ligne et non à la suite

Et le deuxieme essais qui me convient plus qui lui fais un groupe et le colle a la suite mais ca ne marche pas

Svp quelqu'un pour m'aider?

Bonjour

Essaie en remplaçant :

wb2.Sheets("Feuil2").Range("A2:A500").Copy wb3.Sheets("RT").Range("A1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("G2:G500").Copy wb3.Sheets("RT").Range("B1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("J2:J500").Copy wb3.Sheets("RT").Range("C1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("K2:K500").Copy wb3.Sheets("RT").Range("D1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("L2:L500").Copy wb3.Sheets("RT").Range("E1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("V2:V500").Copy wb3.Sheets("RT").Range("F1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("X2:X500").Copy wb3.Sheets("RT").Range("G1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("Y2:Y500").Copy wb3.Sheets("RT").Range("H1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("Z2:Z500").Copy wb3.Sheets("RT").Range("I1").End(xlUp)(2)
wb2.Sheets("Feuil2").Range("AB2:AB500").Copy wb3.Sheets("RT").Range("J1").End(xlUp)(2)

par :

    For i = 1 To 10
        Source = Choose(i, "A2:A500", "G2:G500", "J2:J500", "K2:K500", "L2:L500", "V2:V500", "X2:X500", "Y2:Y500", "Z2:Z500", "AB2:AB500")
        dest = Choose(i, "A1", "B1", "C1", "D1", "E1", "F1", "G1", "H1", "I1", "J1")
        wb2.Sheets("Feuil2").Range(Source).Copy wb3.Sheets("RT").Range(dest)
    Next i

Résultat ?

Bye !