Lecture + remplacement cellules, programme qui boucle indéfiniment

Version imprimable

Bonjour,
J'ai écrit une macro qui - pour chaque dossier de chaque dossier-parent du dossier grand-parent - trouve le fichier Excel du dossier, l'ouvre, lit les différentes feuilles, et pour chaque feuille trouve la colonne "CODE" (qu'on désignera par col, et si par exemple la valeur de la cellule (col , lig) est différente de "X", la cellule (1, lig) reçoit la valeur de la cellule (col, lig).

Sauf que ça ne fonctionne pas. Pour une raison qui m'échappe, le programme tourne indéfiniment. J'ai mis des MsgBox dans mes fonctions DerCol et DerLig, pour m'assurer que ce n'était pas elles qui tournaient ad vitam aeternam, et elles ont l'air de bien fonctionner.

Voici mon code, si quelqu'un a une idée:

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
Dim oFSO As FileSystemObject
Dim dossgramp As Folder, oFld0 As Folder, oFld1 As Folder, oFld2 As Folder
Dim oFl As File
Dim oWB As Workbook
Dim oWS As Worksheet
Dim ContenuCellule As String
Dim i As Integer, col As Integer
Dim Valeur As String
Sub RemplacerNomBaseParCodeX3()
 
 
Set oFSO = New Scripting.FileSystemObject
Set dossgramp = oFSO.GetFolder("C:\Documents and Settings\mclozel\Desktop\BASE DE DONNEES COMPOSANTS MECANIQUES CATIA V5R18\MODELES\")
 
For Each oFld0 In dossgramp.SubFolders
    For Each oFld1 In oFld0.SubFolders
        For Each oFl In oFld1.Files
            If oFSO.GetAbsolutePathName(oFl) Like "*.xls*" Then
                Set oWB = Workbooks.Open(oFl)
                For Each oWS In oWB.Sheets
                    oWS.Activate
                    For col = 1 To DerCol(oWS)
                        ContenuCellule = CStr(oWS.Cells(col & ",1").Value)
                        If ContenuCellule Like "*CODE*" Then
                            For i = 2 To DerLig(oWS)
                                If Not CStr(oWS.Cells(col & "," & i).Value) = "X" Then
                                    Valeur = CStr(oWS.Cells(col & "," & i))
                                    oWS.Cells("1," & i) = Valeur
                                End If
                            Next i
                        End If
                    Next col
                Next oWS
                oWB.Close True
            End If
        Next oFl
    Next oFld1
Next oFld0
 
End Sub
 
Function DerCol(WS As Worksheet) As Integer
  lig = 2
  col = 1
  Do Until IsEmpty(WS.Cells(lig, col))
        col = col + 1
  Loop
  DerCol = col - 1
End Function
 
Function DerLig(WS As Worksheet) As Integer
  lig = 1
  col = 1
  Do Until IsEmpty(WS.Cells(lig, col))
        lig = lig + 1
  Loop
  DerLig = lig - 1
End Function

A +!

08/07/2013, 13h11
Invité

Bonjour,

Je pense que vous inversez les lignes et les colonnes. Avec la notation Cells (à la différence de Range), la ligne est le premier élément, la colonne le deuxième dans vos lignes de code de ce type :

Code:

(oWS.Cells(col & ",1")

Par ailleurs, il est inutile de mettre 1 entre guillemets.

Vous devriez avoir :

Code:

(oWS.Cells(1, col)

Cordialement.
08/07/2013, 14h04
many6976

Ah, merci, je ne savais pas!
(Vous savez pourquoi Range et Cells sont différents sur ce point, historiquement? ça m'intrigue)

En tout cas, ça ne boucle plus, mais malgré les modifications, ça ne fait pas ce que je pensais, je vais donc reprendre mon algorithme pas à pas, je vous dis si je trouve.

OK, problème réglé!

Voici le code au cas où ça aiderait quelqu'un!

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
Dim oFSO As FileSystemObject
Dim dossgramp As Folder, oFld0 As Folder, oFld1 As Folder, oFld2 As Folder
Dim oFl As File
Dim oWB As Workbook
Dim oWS As Worksheet
Dim TitreCol As String
Dim i As Integer, col As Integer
Dim Valeur As String
Dim LastCol As Integer, LastLin As Integer
Sub RemplacerNomBaseParCodeX3()
 
Set oFSO = New Scripting.FileSystemObject
Set dossgramp = oFSO.GetFolder("C:\Documents and Settings\mclozel\Desktop\BASE DE DONNEES COMPOSANTS MECANIQUES CATIA V5R18\MODELES\")
For Each oFld0 In dossgramp.SubFolders
    For Each oFld1 In oFld0.SubFolders
        For Each oFl In oFld1.Files
            If oFSO.GetAbsolutePathName(oFl) Like "*.xls*" Then
                Set oWB = Workbooks.Open(oFl)
                For Each oWS In oWB.Worksheets
                    oWS.Activate
                    LastCol = DerCol(oWS)
                    LastLin = DerLig(oWS)
                    For col = 1 To LastCol
                        TitreCol = CStr(oWS.Cells(1, col).Value)
                        If TitreCol Like "*CODE*" Then
                            For i = 2 To LastLin
                                If Not CStr(oWS.Cells(i, col).Value) = "X" Then
                                    Valeur = CStr(oWS.Cells(i, col))
                                    oWS.Cells(i, 1) = Valeur
                                End If
                            Next i
                        End If
                    Next col
                Next oWS
                oWB.Close True
            End If
        Next oFl
    Next oFld1
Next oFld0
 
End Sub
 
Function DerCol(WS As Worksheet) As Integer
 
  lig = 1
  col = 1
  Do Until IsEmpty(WS.Cells(lig, col))
    col = col + 1
  Loop
  DerCol = col - 1
 
End Function
 
Function DerLig(WS As Worksheet) As Integer
 
  lig = 1
  col = 1
  Do Until IsEmpty(oWS.Cells(lig, col))
    lig = lig + 1
  Loop
  DerLig = lig - 1
 
End Function

(J'avais oublié d'échanger les lignes et colonnes à un endroit... :aie: )

Merci beaucoup M.Kergresse!

Bonne journée!