End If sans bloc If

**Harkebe** · 12/07/2019, 16h09

Bonjour le forum,

Je vous présente tout d'abord ce 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
53
54
55
56
57
58
59
60
61
Sub E4_WIP()

Dim fso As Object       'Système de fichiers
Dim rep As Object       'Répertoire
Dim cfr As Object       'Collection de fichiers du répertoire
Dim fic As Object       'Fichier (élément de la collection cfr)
Dim wbk As Workbook     'Classeur
Dim res As Workbook     'Classeur resultat
Dim rng As Range        'Plage de cellules
Dim dst As Range        'Cellule de destination
Dim pth As String       'Chemin du répertoire
Dim etc As Boolean      'En tête copié
Const lig$ = "4"        'Adresse de la première ligne des tableaux à copier
Const col$ = "C"        'Adresse de la colonne à tester

  ' Définir le répertoire à lire
  pth = ThisWorkbook.Path & \tmp
  ' Créer le fichier résultat
  Set res = Workbooks.Add(xlWBATWorksheet)
  Set dst = res.Worksheets(1).Range("C1")
  ' Lecture du répertoire
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set rep = fso.GetFolder(pth)
  Set cfr = rep.Files
  ' Contrôler chaque fichier du répertoire
  For Each fic In cfr
    ' - Vérifier s'il s'agit d'un fichier Excel...
    If StrComp(fso.GetExtensionName(fic.Name), "xls", vbTextCompare) = 0 Then
      ' ... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons
      Set wbk = Workbooks.Open(Filename:=pth & "\" & fic.Name, UpdateLinks:=xlUpdateLinksAlways)
      ' Définir les lignes à copier
      For j = 1 To wbk.Sheets.Count
        If wbk.Worksheets(j).Name Like "*WIP*" Then
            With wbk.Worksheets(i)
                .Range("C1").Cut .Range("E1")
                For i = 15 To 1 Step -1
                    If Not .Cells(lig, i).Find("HYPERION") Or .Cells(lig, i).Find("Hyperion") Or .Cells(lig, i).Find("hyperion") Is Nothing Then
                        .Cells(lig, i).EntireColumn.Delete
                    End If
                Next i
        
                Set rng = .Rows(lig & ":" & .Cells(.Rows.Count, col).End(xlUp).Row)
            End With
            ' Si l'en-tête est déjà copié ....
            If etc Then
                ' ... réduire les lignes aux données sans en-tête
                Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
            End If
            ' Copier les lignes entières
            rng.Copy dst
            ' En-tête copié
            etc = True
            ' Destination suivante
            Set dst = dst.Offset(rng.Rows.Count)
        End If
      ' Fermer le fichier sans le modifier
      wbk.Close False
    End If
  Next fic

End Sub

Quand j'essaie de lancer la macro, elle plante car il y a un end if sans bloc if (celui souligné et en gras), alors que j'ai compté il y a autant de If que de End If (ou alors je suis trop fatigué pour m'en rendre compte...). Quand je le supprime ça me pose problème au Next fic "Référence de variable de contrôle incorrecte dans Next" (donc logiquement il manque un end if...).

Bref je m'arrache les cheveux depuis tout à l'heure sans comprendre...

Le but de la macro : dans un répertoire, il y a plusieurs classeurs, chacun de ces classeurs a une seule feuille qui m'intéresse, et que je souhaite récupérer dans un nouveau classeur résultat, le tout assemblé sur une seule et même feuille. Par contre je retraite un peu les feuilles avant de copier les données pour supprimer des éléments inutiles.

Merci d'avance pour votre aide.

**Harkebe** · 12/07/2019, 16h19

Envoyé par Harkebe

Bonjour le forum,

Je vous présente tout d'abord ce 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
53
54
55
56
57
58
59
60
61
Sub E4_WIP()

Dim fso As Object       'Système de fichiers
Dim rep As Object       'Répertoire
Dim cfr As Object       'Collection de fichiers du répertoire
Dim fic As Object       'Fichier (élément de la collection cfr)
Dim wbk As Workbook     'Classeur
Dim res As Workbook     'Classeur resultat
Dim rng As Range        'Plage de cellules
Dim dst As Range        'Cellule de destination
Dim pth As String       'Chemin du répertoire
Dim etc As Boolean      'En tête copié
Const lig$ = "4"        'Adresse de la première ligne des tableaux à copier
Const col$ = "C"        'Adresse de la colonne à tester

  ' Définir le répertoire à lire
  pth = ThisWorkbook.Path & \tmp
  ' Créer le fichier résultat
  Set res = Workbooks.Add(xlWBATWorksheet)
  Set dst = res.Worksheets(1).Range("C1")
  ' Lecture du répertoire
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set rep = fso.GetFolder(pth)
  Set cfr = rep.Files
  ' Contrôler chaque fichier du répertoire
  For Each fic In cfr
    ' - Vérifier s'il s'agit d'un fichier Excel...
    If StrComp(fso.GetExtensionName(fic.Name), "xls", vbTextCompare) = 0 Then
      ' ... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons
      Set wbk = Workbooks.Open(Filename:=pth & "\" & fic.Name, UpdateLinks:=xlUpdateLinksAlways)
      ' Définir les lignes à copier
      For j = 1 To wbk.Sheets.Count
        If wbk.Worksheets(j).Name Like "*WIP*" Then
            With wbk.Worksheets(i)
                .Range("C1").Cut .Range("E1")
                For i = 15 To 1 Step -1
                    If Not .Cells(lig, i).Find("HYPERION") Or .Cells(lig, i).Find("Hyperion") Or .Cells(lig, i).Find("hyperion") Is Nothing Then
                        .Cells(lig, i).EntireColumn.Delete
                    End If
                Next i
        
                Set rng = .Rows(lig & ":" & .Cells(.Rows.Count, col).End(xlUp).Row)
            End With
            ' Si l'en-tête est déjà copié ....
            If etc Then
                ' ... réduire les lignes aux données sans en-tête
                Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
            End If
            ' Copier les lignes entières
            rng.Copy dst
            ' En-tête copié
            etc = True
            ' Destination suivante
            Set dst = dst.Offset(rng.Rows.Count)
        End If
      ' Fermer le fichier sans le modifier
      wbk.Close False
    End If
  Next fic

End Sub

Quand j'essaie de lancer la macro, elle plante car il y a un end if sans bloc if (celui souligné et en gras), alors que j'ai compté il y a autant de If que de End If (ou alors je suis trop fatigué pour m'en rendre compte...). Quand je le supprime ça me pose problème au Next fic "Référence de variable de contrôle incorrecte dans Next" (donc logiquement il manque un end if...).

Bref je m'arrache les cheveux depuis tout à l'heure sans comprendre...

Le but de la macro : dans un répertoire, il y a plusieurs classeurs, chacun de ces classeurs a une seule feuille qui m'intéresse, et que je souhaite récupérer dans un nouveau classeur résultat, le tout assemblé sur une seule et même feuille. Par contre je retraite un peu les feuilles avant de copier les données pour supprimer des éléments inutiles.

Merci d'avance pour votre aide.

Je viens de me rendre compte que j'ai oublié de boucler le j, à trop me concentrer sur le nombre de If... End If, ce détail m'a complètement échappé.

Topic résolu, navré pour le dérangement.

End If sans bloc If [XL-2016]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager