Problèmes avec Loop- copier une plage de donnée de plusieurs excels vers un seul

**S.Mag** · 07/06/2017, 14h49

Bonjour,

Je souhaite copier une plage de donnée et deux cellules fixes, pour plusieurs excels identiques de formes, ceci vers un nouvel excel qui regroupe toutes les infos copiés et coller l'une après l'autre.

J'ai réussi à le faire pour un seul fichier excel mais pas pour plusieurs en même temps, en faisant une loop.
Sachant que la plage de donnée est variable entre les fichiers en fonction du nombre de lignes. Par exemple le premier peut avoir la plage C13:N50, le 2nd C13:N55 etc

Voici le code pour un seul fichier qui fonctionne correctement sans erreur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Copy()
Dim x As Workbook
Dim y As Workbook
Dim lastRow
'## Open both workbooks first:
Set x = Workbooks.Open("Z:\VBA\PARA\DOUARNENEZ_DEVIS_2 MAI.xlsx")
Set y = Workbooks.Open("Z:\VBA\base-macro.xlsx")
 
    lastRow = x.Sheets("Para RF").Range("C" & Rows.count).End(xlUp).Row
 
    x.Sheets("Para RF").Range("C13:N" & lastRow).Copy
    y.Sheets("Feuil2").Range("C2").PasteSpecial (xlPasteValues)
 
    x.Sheets("Para RF").Range("D6").Copy
    y.Sheets("Feuil2").Range("A2:A" & lastRow).PasteSpecial (xlPasteValues)
 
    x.Sheets("Para RF").Range("F8").Copy
    y.Sheets("Feuil2").Range("B2:B" & lastRow).PasteSpecial (xlPasteValues)
 
    y.Close saveChanges:=True
 
    x.Close saveChanges:=False
End Sub

maintenant j'essaye de faire la loop pour 4 fichiers dans le folder test:
le but de ma loop est d'automatiser le copy et copier les infos du 2nd fichier après les infos du 1er fichier et le 3eme apres le 2eme etc, tout le résultat doit être dans un même fichier excel destination : base-macro

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Sub copy_ville_société()
 
Dim mypath, myExtension, myfile, x, y, i, lastRow
 
 
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
 
    mypath = "Z:\VBA\Test\"
 
 
 
'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"
 
'Target Path with Ending Extention
 
  myfile = Dir(mypath & myExtension)
Set y = Workbooks.Open("Z:\VBA\base-macro.xlsx") 'destination
 
 For i = 1 To 4
 
Set x = Workbooks.Open(mypath & myfile) 'sources
 
 
lastRow = x.Sheets("Para RF").Range("C" & Rows.count).End(xlUp).Row 'dernière ligne dans sources qui est variable selon le fichier
 
    x.Sheets("Para RF").Range("C13:N" & lastRow).Copy
    y.Sheets("Feuil2").Range("C" & i + 1).PasteSpecial (xlPasteValues)
 
    x.Sheets("Para RF").Range("D6").Copy 'ville = tjs en D6
    y.Sheets("Feuil2").Range("A" & i + 1 & ":A" & lastRow).PasteSpecial (xlPasteValues) 'je veux que la ville se répète pour toutes les lignes copiés de chaque fichier
 
    x.Sheets("Para RF").Range("F8").Copy 'Société = tjs  en F8
    y.Sheets("Feuil2").Range("B" & i + 1 & ":B" & lastRow).PasteSpecial (xlPasteValues) 'je veux que la société se répète pour toutes les lignes copiés de chaque fichier
 
    x.Close saveChanges:=False
    y.Close saveChanges:=True
 
    Next i
 
End Sub

en exécutant le code, j'ai un message d'erreur: erreur d'exécution 424: Objet requis. ceci sur cette partie du code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

y.Sheets("Feuil2").Range("C" & i + 1).PasteSpecial (xlPasteValues)

j'ai vérifié le fichier source j'ai obtenu un résultat pour le premier fichier copié, donc l'erreur ce fait au moment du copie du 2ème fichier.

je sais c'est pas logique le i que j'ai mis car i = 2 pour le premier mais pour le 2nd doit être placé à la ligne 50 par exemple or j'ai indiqué i =1 à 4 car j'ai 4 fichiers pour la loop.

je fais comment?

pouvez vous m'aider s'il vous plait?

merci beaucoup pour vos aides et suggestions.

Cheers!

**riaolle** · 07/06/2017, 15h35

Bonjour,
Quand est-ce que tu définis le nom de tes fichiers ?
Tu écris :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

myfile = Dir(mypath & myExtension)

Puis,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set x = Workbooks.Open(mypath & myfile)

Donc, au final tu veux ouvrir le fichier dont le nom est : "Z:\VBA\Test\Z:\VBA\Test\.xls"
Quels sont les noms des fichiers ? Est-il possible de faire une boucle avec le nom des fichiers ? Par exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
For i = 1 to 4
    myfile = "mon_fichier" & i
    Set x = Workbooks.Open(mypath & myfile)
'...
Next i

Tu aurais les fichier nommés mon_fichier1 à mon_fichier4.

**S.Mag** · 07/06/2017, 16h34

Envoyé par riaolle

Bonjour,
Quand est-ce que tu définis le nom de tes fichiers ?
Tu écris :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

myfile = Dir(mypath & myExtension)

Puis,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set x = Workbooks.Open(mypath & myfile)

Donc, au final tu veux ouvrir le fichier dont le nom est : "Z:\VBA\Test\Z:\VBA\Test\.xls"
Quels sont les noms des fichiers ? Est-il possible de faire une boucle avec le nom des fichiers ? Par exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
For i = 1 to 4
    myfile = "mon_fichier" & i
    Set x = Workbooks.Open(mypath & myfile)
'...
Next i

Tu aurais les fichier nommés mon_fichier1 à mon_fichier4.

non je pense pas que c'est ça le problème! j'ai déja utilisé cela pour d'autres loop et j'ai aucun souci.
le souci qu'il arrive pas à ouvrir et copier le deuxième fichier à la suite du premier dans destination.

pour cela j'ai essayé de faire une loop do while

**S.Mag** · 07/06/2017, 16h45

j'ai essayé avec ce nouveau code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Sub copy_ville_société()
 
Dim mypath, myExtension, myfile, x, y, i, lastRow, TmpRng
 
 
Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
 
    mypath = "Z:\VBA\Test\"
 
 
 
'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"
 
'Target Path with Ending Extention
  myfile = Dir(mypath & myExtension)
Set y = Workbooks.Open("Z:\VBA\base-macro.xlsx")
TmpRng = 1
 Do While myfile <> ""
 
Set x = Workbooks.Open(mypath & myfile)
 
 
lastRow = x.Sheets("Para RF").Range("C" & Rows.count).End(xlUp).Row
    TmpRng = y.Sheets(2).Cells(Rows.count, 1).End(xlUp).Row + 1 'copy in the next empty cell of column A
 
 
 
    x.Sheets("Para RF").Range("C13:N" & lastRow).Copy
    y.Sheets("Feuil2").Range("C" & TmpRng).PasteSpecial (xlPasteValues)
 
    x.Sheets("Para RF").Range("D6").Copy
    y.Sheets("Feuil2").Range("A" & TmpRng & ":A" & lastRow).PasteSpecial (xlPasteValues)
 
    x.Sheets("Para RF").Range("F8").Copy
    y.Sheets("Feuil2").Range("B" & TmpRng & ":B" & lastRow).PasteSpecial (xlPasteValues)
 
 
 
    x.Close saveChanges:=False
    y.Close saveChanges:=True
 
    myfile = Dir()
Loop
 
 
Application.DisplayAlerts = True
 
End Sub

j'ai une erreur au moment du 2nd fichier! le bug est ici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

y.Sheets("Feuil2").Range("C" & TmpRng).PasteSpecial (xlPasteValues)

je pense le problème est au collage il sait pas où coller le 2nd fichier

**S.Mag** · 07/06/2017, 17h03

Non l'erreur est dans le collage.
Comment je dit à la loop de coller sur la ligne suivante? Qui peut être 30 ou 40
Ce n'est pas la même chose qu'avant!

Invité · 07/06/2017, 16h39

bonjour,
ça ressemble étrangement à ce poste là!

https://www.developpez.net/forums/d1...a/#post9346353

Invité · 07/06/2017, 17h04

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
 
 
Sub copy_ville_société()
Dim mypath, myExtension, myfile, x, y, i, lastRow, TmpRng
Application.ScreenUpdating = False: Application.EnableEvents = False: Application.Calculation = xlCalculationManual: Application.DisplayAlerts = False
mypath = "Z:\VBA\Test\"
myExtension = "*.xls*" 'Target File Extension (must include wildcard "*")
myfile = Dir(mypath & myExtension) 'Target Path with Ending Extention
Set y = Workbooks.Open("Z:\VBA\base-macro.xlsx")
TmpRng = 1
Do While myfile <> ""
    Set x = Workbooks.Open(mypath & myfile)
    With x.Sheets("Para RF")
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        TmpRng = y.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1 'copy in the next empty cell of column A
        With .Range("C13:N" & lastRow)
            y.Sheets("Feuil2").Range("C" & TmpRng).Resize(.Rows.Count, .Columns.Count).Value = .Value
       End With
        y.Sheets("Feuil2").Range("A" & TmpRng & ":A" & lastRow).Value = .Range("D6").Value
        y.Sheets("Feuil2").Range("B" & TmpRng & ":B" & lastRow).Value = .Range("F8").Value
        x.Close saveChanges:=False
        y.Close saveChanges:=True
        myfile = Dir()
    End With
Loop
pplication.DisplayAlerts = True
End Sub

**S.Mag** · 07/06/2017, 17h15

Envoyé par dysorthographie

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
 
 
Sub copy_ville_société()
Dim mypath, myExtension, myfile, x, y, i, lastRow, TmpRng
Application.ScreenUpdating = False: Application.EnableEvents = False: Application.Calculation = xlCalculationManual: Application.DisplayAlerts = False
mypath = "Z:\VBA\Test\"
myExtension = "*.xls*" 'Target File Extension (must include wildcard "*")
myfile = Dir(mypath & myExtension) 'Target Path with Ending Extention
Set y = Workbooks.Open("Z:\VBA\base-macro.xlsx")
TmpRng = 1
Do While myfile <> ""
    Set x = Workbooks.Open(mypath & myfile)
    With x.Sheets("Para RF")
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        TmpRng = y.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1 'copy in the next empty cell of column A
        With .Range("C13:N" & lastRow)
            y.Sheets("Feuil2").Range("C" & TmpRng).Resize(.Rows.Count, .Columns.Count).Value = .Value
       End With
        y.Sheets("Feuil2").Range("A" & TmpRng & ":A" & lastRow).Value = .Range("D6").Value
        y.Sheets("Feuil2").Range("B" & TmpRng & ":B" & lastRow).Value = .Range("F8").Value
        x.Close saveChanges:=False
        y.Close saveChanges:=True
        myfile = Dir()
    End With
Loop
pplication.DisplayAlerts = True
End Sub

Merci bcp

Invité · 07/06/2017, 17h33

Tu fais y.Close saveChanges:=True avant le myfile = Dir() mais tu ouvre le fichier avant le do while???

Comment ça peut fonctionner?

**S.Mag** · 07/06/2017, 17h40

Envoyé par dysorthographie

Tu fais y.Close saveChanges:=True avant le myfile = Dir() mais tu ouvre le fichier avant le do while???

Comment ça peut fonctionner?

J'ai pas fait attention ⚠️
Merci 😊

**S.Mag** · 08/06/2017, 09h38

Envoyé par dysorthographie

Tu fais y.Close saveChanges:=True avant le myfile = Dir() mais tu ouvre le fichier avant le do while???

Comment ça peut fonctionner?

Bonjour,

j'ai exécuté le code, mais j'ai une erreur dans cette ligne de code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

TmpRng = y.Sheets(2).Cells(Rows.count, 1).End(xlUp).Row + 1 'copy in the next empty cell of column A

j'ai un message d'erreur: Objet requis, erreur d’exécution 424

sachant que j'ai bien corrigé: j'ai mis

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
myfile = Dir()
        x.Close saveChanges:=False
        y.Close saveChanges:=True

Invité · 07/06/2017, 17h43

C'est très important d'épurer son code et de l'indenter ! Pas de sauts de lignes ça nuit à la lisibilité alors qu'on pense à tord le contraire!

On est passé de 52 lignes à 27 si on retire les 2 premières lignes inutiles ca fait 25!

**S.Mag** · 07/06/2017, 17h45

Envoyé par dysorthographie

C'est très important d'épurer son code et de l'indenter ! Pas de sauts de lignes ça nuit à la lisibilité alors qu'on pense à tord le contraire!

Ça marche je suis débutante avec les codes et la programmation!
Merci infiniment

Invité · 07/06/2017, 17h49

On est là également pour mètre des petites tapes dernière la tête!

Personnellement j'en es déjà mis 2 436!

Invité · 08/06/2017, 09h56

Bonjour,
il faut fermer le fichier Y à la fin du traitement après le loop!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub copy_ville_société()
Dim mypath, myExtension, myfile, x, y, i, lastRow, TmpRng
Application.ScreenUpdating = False: Application.EnableEvents = False: Application.Calculation = xlCalculationManual: Application.DisplayAlerts = False
mypath = "Z:\VBA\Test\"
myExtension = "*.xls*" 'Target File Extension (must include wildcard "*")
myfile = Dir(mypath & myExtension) 'Target Path with Ending Extention
Set y = Workbooks.Open("Z:\VBA\base-macro.xlsx")
TmpRng = 1
Do While myfile <> ""
    Set x = Workbooks.Open(mypath & myfile)
    With x.Sheets("Para RF")
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        TmpRng = y.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1 'copy in the next empty cell of column A
        With .Range("C13:N" & lastRow)
            y.Sheets("Feuil2").Range("C" & TmpRng).Resize(.Rows.Count, .Columns.Count).Value = .Value
       End With
        y.Sheets("Feuil2").Range("A" & TmpRng & ":A" & lastRow).Value = .Range("D6").Value
        y.Sheets("Feuil2").Range("B" & TmpRng & ":B" & lastRow).Value = .Range("F8").Value
        x.Close saveChanges:=False
        'y.Close saveChanges:=True
        myfile = Dir()
    End With
Loop
y.Close saveChanges:=True
pplication.DisplayAlerts = True
End Sub

**S.Mag** · 08/06/2017, 10h34

Envoyé par dysorthographie

Bonjour,
il faut fermer le fichier Y à la fin du traitement après le loop!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub copy_ville_société()
Dim mypath, myExtension, myfile, x, y, i, lastRow, TmpRng
Application.ScreenUpdating = False: Application.EnableEvents = False: Application.Calculation = xlCalculationManual: Application.DisplayAlerts = False
mypath = "Z:\VBA\Test\"
myExtension = "*.xls*" 'Target File Extension (must include wildcard "*")
myfile = Dir(mypath & myExtension) 'Target Path with Ending Extention
Set y = Workbooks.Open("Z:\VBA\base-macro.xlsx")
TmpRng = 1
Do While myfile <> ""
    Set x = Workbooks.Open(mypath & myfile)
    With x.Sheets("Para RF")
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        TmpRng = y.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1 'copy in the next empty cell of column A
        With .Range("C13:N" & lastRow)
            y.Sheets("Feuil2").Range("C" & TmpRng).Resize(.Rows.Count, .Columns.Count).Value = .Value
       End With
        y.Sheets("Feuil2").Range("A" & TmpRng & ":A" & lastRow).Value = .Range("D6").Value
        y.Sheets("Feuil2").Range("B" & TmpRng & ":B" & lastRow).Value = .Range("F8").Value
        x.Close saveChanges:=False
        'y.Close saveChanges:=True
        myfile = Dir()
    End With
Loop
y.Close saveChanges:=True
pplication.DisplayAlerts = True
End Sub

Merci

Problèmes avec Loop- copier une plage de donnée de plusieurs excels vers un seul [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager