Code VBA pour parcourir les feuilles d'un classeur Excel

Version imprimable

Bonjour à tous, je suis un débutant sur VBA excel. J'ai des petits soucis avec un code. Si quelqu'un peut me venir en aide.

En fait, mon problème est le suivant :

Je souhaite ouvrir 04 classeurs dans des emplacements différents, parcourir les feuilles de chaque classeur et copier des données d'une certaine plage et les coller dans un autre classeur.

Code:

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
Private Sub Btn_Importer_Click ()
 
Dim j As String
Dim Wsht1 As Worksheet
 
Windows("Rapport_Hebdo_Format.xlsm").Activate
 
Nom_Fichier_1 = Sheets("Tuning").Cells(6, 2).Value
Dossier_source_1 = Sheets("Tuning").Cells(8, 2).Value
 
Nom_Fichier_2 = Sheets("Tuning").Cells(10, 2).Value
Dossier_source_2 = Sheets("Tuning").Cells(12, 2).Value
 
Nom_Fichier_3 = Sheets("Tuning").Cells(14, 2).Value
Dossier_source_3 = Sheets("Tuning").Cells(16, 2).Value
 
Nom_Fichier_4 = Sheets("Tuning").Cells(18, 2).Value
Dossier_source_4 = Sheets("Tuning").Cells(20, 2).Value
 
On Error Resume Next
 
Application.ScreenUpdating = False
 
Workbooks.Open Filename:=Dossier_source_1 & Nom_Fichier_1
Workbooks.Open Filename:=Dossier_source_2 & Nom_Fichier_2
Workbooks.Open Filename:=Dossier_source_3 & Nom_Fichier_3
Workbooks.Open Filename:=Dossier_source_4 & Nom_Fichier_4
 
Windows("Rapport_Hebdo_Format.xlsm").Activate
Sheets("Tuning").Select
 
Application.ScreenUpdating = True
 
 
' Importer des données d'une feuille du premier classeur et les coller dans le classeur Rapport_Hebdo_Format, feuille Rapport'

C'est le code ci-dessous qui me donne des soucis.

Merci d'avance pour cette assistance.

Code:

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
Windows("Rapport_Hebdo_Format.xlsm").Activate
Sheets("Tuning").Select
 
j = Sheets("Tuning").Cells(7, 2).Value   
 
Workbooks(Dossier_source_1 & Nom_Fichier_1).Activate
 
For Each Wsht1 In thisworkbooks
 
    If Wsht1.Name = j Then
 
        range("A5:K5").select
        Selection.copy
 
        Windows("Rapport_Hebdo_Format.xlsm").Activate
        range("A1")
        Paste selection.copy
 
 
    End If
 
 
Next Wsht1
 
 
 
End Sub

23/02/2019, 09h37
eriiic

Bonjour,

et si tu précisais le soucis en question, tu ne crois pas que ça aiderait à t'aider ?

Code:

On Error Resume Next

tu dois le faire suivre de On Error Goto 0 dès que tu n'as plus besoin de suspendre le traitement d'erreur (après l'ouverture des fichiers je suppose).
Sinon tu peux cacher d'autres erreurs que tu dois corriger car anormales.

Code:

For Each Wsht1 In thisworkbooks

thisworkbooks est resté en minuscules, ça doit t'alerter. C'est ThisWorkbook
Et ThisWorkbook est le classeur contenant cette macro, tu veux le ActiveWorkbook je suppose.
D'ailleurs il faut éviter d'activer les objets lorsque tu peux. Les déclarer dans une variable et travailler avec celle-ci.
eric
23/02/2019, 10h02
Dayane86

Éric merci beaucoup pour ces éclaircissements.
Je veux pour chaque activeWorkbook, vérifier si le nom de la feuille 1 correspond au nom indiqué dans une cellule, sélectionner cette feuille, copier des plages et les coller sur une feuille d'un autre classeur. Existe t-il un code assez simple ?
Merci d'avance pour vos réponses.

1 pièce(s) jointe(s)

Bonjour,

Un exemple de code :

Code:

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
53
54
55
56
Option Explicit
Public Sub Btn_Importer_Click()
'
Dim wbk As Workbook
Dim cel As Range
Dim nom As String
Dim msg As String
Dim i As Integer
 
  Set cel = ThisWorkbook.Worksheets("Tuning").Cells(6, 2)
  Application.ScreenUpdating = False
  For i = 1 To 4
    ' Ouvrir le fichier
    nom = cel.Value & cel.Offset(2).Value
    On Error Resume Next
    Set wbk = Workbooks.Open(Filename:=nom)
    On Error GoTo 0
    If Not wbk Is Nothing Then
      ' Copier les données
      Call CopierDonnées(wbk, cel, msg)
      wbk.Close False
    Else
      ' Mémoriser le nom du fichier non trouvé
      msg = msg & vbCrLf & "- fichier « " & nom & " »"
      ' Effacer les anciennes données
      cel.Offset(1, 1).Resize(1, 11).Value = Empty
    End If
    ' Fichier suivant
    Set wbk = Nothing
    Set cel = cel.Offset(4)
  Next i
  Application.ScreenUpdating = True
  If msg > "" Then MsgBox "Non trouvé(s) :" & msg
End Sub
 
Private Sub CopierDonnées(wbk As Workbook, cel As Range, msg As String)
'
Dim wsh As Worksheet
Dim nom As String
 
  ' Choisir la feuille
  nom = cel.Offset(1).Value
  On Error Resume Next
  Set wsh = wbk.Worksheets(nom)
  On Error GoTo 0
  If Not wsh Is Nothing Then
    ' Copier les données
    wsh.Range("A5:K5").Copy cel.Offset(1, 1)
  Else
    ' Mémoriser le nom de la feuille non trouvée
    msg = msg & vbCrLf & "- feuille « " & nom & " » du fichier « " & wbk.FullName & " »"
    ' Effacer les anciennes données
    cel.Offset(1, 1).Resize(1, 11).Value = Empty
  End If
 
End Sub

Et le fichier correspondant :
Pièce jointe 452683

23/02/2019, 19h39
Dayane86

Patrice, merci beaucoup pour ce retour. Je vais l'adapter à mon programme et ensuite je vous reviendrai...
23/02/2019, 21h51
Dayane86

Bonsoir Patrice,

J'ai regardé ton code. Ca peut résoudre mon problème mais pourriez vous me guider par rapport au code en boucle pour faire la copie
d'une plage 1 du classeur 1 et la coller dans une plage d'un classeur A
d'une plage 2 du classeur 2 et la coller dans une plage d'un classeur A
d'une plage 3 du classeur 3 et la coller dans une plage d'un classeur A
d'une plage 4 du classeur 4 et la coller dans une plage d'un classeur A

Merci d'avance pour tes éclairages.
23/02/2019, 23h41
Patrice740

Citation:

Envoyé par Dayane86

Bonsoir Patrice,
J'ai regardé ton code. Ca peut résoudre mon problème mais pourriez vous me guider par rapport au code en boucle pour faire la copie
d'une plage 1 du classeur 1 et la coller dans une plage d'un classeur A
d'une plage 2 du classeur 2 et la coller dans une plage d'un classeur A
d'une plage 3 du classeur 3 et la coller dans une plage d'un classeur A
d'une plage 4 du classeur 4 et la coller dans une plage d'un classeur A
Merci d'avance pour tes éclairages.

C'est ce que fait le code : il copie la plage A5:K5 de chacun des 4 classeurs vers le classeur qui contient la macro.

Il est assez facile de l'adapter, encore faudrait-il que tu précises ce que tu voudrais !
Comment sont définies les plages 1, 2, 3 et 4 ? Vers où dans le classeur destination ?

Bonjour Patrice, effectivement, c'est ce que fait le code. Mais mon souci maintenant c'est de copier des plages différentes de chaque classeur et les coller sur une autre feuille du classeur qui contient la macro.
Genre :

Code:

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
53
54
55
56
57
58
59
60
61
62
63
64
65
Dim wsh1 As Worksheet
Dim wsh2 As Worksheet
Dim wsh3 As Worksheet
Dim wsh4 As Worksheet
 
Dim nom1 As String
Dim nom2 As String
Dim nom3 As String
Dim nom4 As String
 
Set cel = ThisWorkbook.Worksheets("Tuning").Cells(6, 2)
  ' Choisir la feuille
  nom1= cel.Offset(1).Value
  nom2= cel.Offset(5).Value
  nom3= cel.Offset(9).Value
  nom4= cel.Offset(13).Value
   On Error Resume Next
  Set wsh1 = wbk.Worksheets(nom1)
  Set wsh2 = wbk.Worksheets(nom2)
  Set wsh3 = wbk.Worksheets(nom3)
  Set wsh4 = wbk.Worksheets(nom4)
  On Error GoTo 0
  If Not wsh1 Is Nothing Then
    ' Copier les données du classeur 1 et la feuille5
    wsh1.Range("A5:K5").Copy cel.Offset(1, 1)
  Else
    ' Mémoriser le nom de la feuille non trouvée
    msg = msg & vbCrLf & "- feuille « " & nom & " » du fichier « " & wbk.FullName & " »"
    ' Effacer les anciennes données
    cel.Offset(1, 1).Resize(1, 11).Value = Empty
  End If
 
 
  If Not wsh2 Is Nothing Then
    '   Copier les données du classeur 2 et la feuille1
    wsh2.Range("B5:D5").Copy cel.Offset(1, 1)
  Else
    ' Mémoriser le nom de la feuille non trouvée
    msg = msg & vbCrLf & "- feuille « " & nom & " » du fichier « " & wbk.FullName & " »"
    ' Effacer les anciennes données
    cel.Offset(1, 1).Resize(1, 11).Value = Empty
  End If
 
  If Not wsh3 Is Nothing Then
    ' Copier les données du classeur 3 et la feuille1
    wsh3.Range("C5:O5").Copy cel.Offset(1, 1)
  Else
    ' Mémoriser le nom de la feuille non trouvée
    msg = msg & vbCrLf & "- feuille « " & nom & " » du fichier « " & wbk.FullName & " »"
    ' Effacer les anciennes données
    cel.Offset(1, 1).Resize(1, 11).Value = Empty
  End If
 
  If Not wsh4 Is Nothing Then
    '  Copier les données du classeur 4 et la feuille1
    wsh4.Range("A5:O5").Copy cel.Offset(1, 1)
  Else
    ' Mémoriser le nom de la feuille non trouvée
    msg = msg & vbCrLf & "- feuille « " & nom & " » du fichier « " & wbk.FullName & " »"
    ' Effacer les anciennes données
    cel.Offset(1, 1).Resize(1, 11).Value = Empty
  End If
 
 
End Sub

A partir de là je souhaite les coller dans le classeur qui contient la macro sur une feuille 2

Merci d'avance pour les éclairages.

1 pièce(s) jointe(s)

Bonjour,

Comme tu ne précises toujours pas la destination exacte des données sur la feuille 2, voici une approche plus générique :
Le fichier : Pièce jointe 452804

Et le code utilisé (une seule procédure) :

Code:

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
53
54
55
56
57
58
59
60
Option Explicit
Public Sub Btn_Importer_Click()
'
Dim wbkSource As Workbook
Dim wshSource As Worksheet
Dim celInfoCopie As Range
Dim celCible As Range
Dim nomComplet As String
Dim nomFeuille As String
Dim msg As String
Dim adr As String
 
  Application.ScreenUpdating = False
  ' Première cellule InfoCopie (chemin)
  Set celInfoCopie = ThisWorkbook.Worksheets("Tuning").Cells(6, 2)
  Do While Not IsEmpty(celInfoCopie.Value)
    ' Adresse cellule de destination
    adr = celInfoCopie.Offset(4).Value
    ' Cellule de destination
    Set celCible = ThisWorkbook.Worksheets("Feuil2").Range(adr)
    ' Adresse de la plage à copier
    adr = celInfoCopie.Offset(3).Value
    ' nom complet du fichier source
    nomComplet = celInfoCopie.Value & celInfoCopie.Offset(1).Value
    ' Ouvrir le fichier source
    On Error Resume Next
    Set wbkSource = Workbooks.Open(Filename:=nomComplet)
    On Error GoTo 0
    If Not wbkSource Is Nothing Then
      ' Si le fichier existe, copier les données
      ' - nom de la feuille source
      nomFeuille = celInfoCopie.Offset(2).Value
      ' - définir la feuille
      On Error Resume Next
      Set wshSource = wbkSource.Worksheets(nomFeuille)
      On Error GoTo 0
      If Not wshSource Is Nothing Then
        ' - si la feuille existe, copier les données
        wshSource.Range(adr).Copy celCible
      Else
        ' - si la feuille n'est pas trouvée mémoriser le nom de la feuille
        msg = msg & vbCrLf & "- feuille « " & nomFeuille & " » du fichier « " & wbkSource.FullName & " »"
        ' Effacer les anciennes données
        celCible.Resize(Range(adr).Rows.Count, Range(adr).Columns.Count).Value = Empty
      End If
      ' - fermer le fichier source
      wbkSource.Close False
    Else
      ' Si le fichier n'est pas trouvé, mémoriser le nomComplet du fichier
      msg = msg & vbCrLf & "- fichier « " & nomComplet & " »"
      ' Effacer les anciennes données
      celCible.Resize(Range(adr).Rows.Count, Range(adr).Columns.Count).Value = Empty
    End If
    ' Fichier suivant
    Set wbkSource = Nothing
    Set celInfoCopie = celInfoCopie.Offset(6)
  Loop
  Application.ScreenUpdating = True
  If msg > "" Then MsgBox "Non trouvé(s) :" & msg
End Sub

24/02/2019, 17h22
Dayane86

Bonjour Patrice, merci beaucoup pour cette aide précieuse...Le Code fonctionne à merveille.. Je vais le réadapter à mon problème.