Echec d'attribution de valeur

1 pièce(s) jointe(s)

Salutations,

Je suis en stage sur excel 2016 et ai pour mission d'analysée un gros fichier Excel possédant plus de 10 000 case d'entré de valeur que je dois trouver dans un classeur de plus de 480 000 case. Ainsi j'ai crée un petit code VBA afin de lire et repérer ces cellules or après un malheureux tour, soit la première feuille. le code bug et l'attribution de valeur échoue. Deplus, j'ai créer au sein du classeur une feuille nommé test afin de récupérer des donnée tel que la colonne, ligne, titre et autre. Mais cette dernier prend fin après seulement un tour.

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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
Sub remplissage1()
 
Dim finp As Double
Dim nb As Long, i As Double, j As Long, Finl As Long
Dim nb2 As Long
Dim x As Boolean
Dim y As Integer
Dim k As Long
Dim l As Double
Dim m As Long
Dim n As Long
Dim o As String
 
Dim tws, ws As Worksheet
 
tws = Array("Energie 1", "Energie 2", "Hors énergie 1", "Hors énergie 2", "Intrants 1", "Intrants 2", "Futurs emballages", "Déchets directs", "Fret", "Déplacements", "Immobilisations", "Utilisation", "Fin de vie", "Utilitaires") ' De Energie1 à fin de vie
nb2 = 1 'Conteur Data
j = 1 'conteur de colone
i = 1 'conteur de ligne
finp = 700        ' profondeur/ligne
Finl = 43      'longueur/colonne
nb = j
 
For Each ws In Worksheets(tws)
 
        ws.Select 'Feuille Selectionné
        o = ws.Name
        Do While i <= finp
 
            For j = nb To Finl Step 1
 
            x = False: On Error Resume Next 'conteur de choix multiple
            x = Cells(i, j).Validation.InCellDropdown 'conteur de choix multiple
            y = IIf(x = True, 11111, 0) 'conteur de choix multiple
            'ws.Select 'Debut de la selection
            Cells(i, j).Select
 
            If Not y = 11111 And Not Left(Cells(i, j).Formula, 1) = "=" And Not Cells(i, j).MergeCells And IsNumeric(Cells(i, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous Then
                           nb2 = nb2 + 1
                           Sheets("test").Cells(2, nb2) = ws.Cells(i, j)
                           Sheets("test").Cells(3, nb2) = i
                           Sheets("test").Cells(4, nb2) = j
                           ws.Cells(i, j) = Sheets("test").Cells(1, nb2)
                           Sheets("test").Cells(10, nb2).Value = o ' récupération titre page
                           Sheets("test").Cells(10, nb2).Value = ws.Name ' récupération titre page
                           ' incrementation conteur de variable d'entrée
 
                           l = 1
                           k = 1
                           Do While l = 1 'Récupération du titre de la colonne
                                If Not i = k And i > 1 Then
                                'Cells(i - k, j).Select
                                     If WorksheetFunction.IsText(Cells(i - k, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous Then
                                         Sheets("test").Cells(5, nb2) = ws.Cells(i - k, j)  ' Bordure sup
                                         l = 0
                                     ElseIf WorksheetFunction.IsText(Cells(i - k, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Not i = k Then
                                         Sheets("test").Cells(5, nb2) = ws.Cells(i - k, j)  'contoure
                                          l = 0
                                     ElseIf WorksheetFunction.IsText(Cells(i - k, j)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous Then
                                         Sheets("test").Cells(6, nb2) = ws.Cells(i - k, j)  'bordure inf
                                          k = k + 1
                                     Else
                                         k = k + 1
                                         'MsgBox k
 
                                     End If
                                Else
                                     l = 0
                                End If
                           Loop
 
                          Sheets("test").Cells(7, nb2) = ws.Cells(i, 2) 'Récupération du titre de ligne
 
                          l = 1
                          n = 1
                          Do While l = 1 'Récupération du titre de tableau
                           ' ws.Cells(i - n, 2).Select
                            If WorksheetFunction.IsText(Cells(i - n, 2)) And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Cells(i - n - 1, 2) = "" Then
                                Sheets("test").Cells(8, nb2) = ws.Cells(i - n, 2)
                                l = 0
                            Else
                                n = n + 1
                            End If
                          Loop
 
                          l = 1
                          m = 1
                          Do While l = 1 'Récupération du titre de la catégorie
 
                                If Not i = m And i > 1 Then
                                'Cells(i - m, j).Select
                                     If Cells(i - m, j).MergeCells And Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous And Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous And Selection.Borders(xlEdgeRight).LineStyle = xlContinuous And Selection.Borders(xlEdgeTop).LineStyle = xlContinuous And Not i = m And Cells(i - m + 1, j) = "" And Cells(i - m - 1, j) = "" Then
                                                Selection.Copy
                                                Sheets("test").Select
                                                Cells(9, nb2).Select
                                                ActiveSheet.Paste
                                                Application.CutCopyMode = False
                                                Selection.UnMerge
 
                                                With Selection.Font
                                                    .ThemeColor = xlThemeColorLight1
                                                    .TintAndShade = 0
                                                End With
                                                With Selection.Interior
                                                    .Pattern = xlSolid
                                                    .PatternColorIndex = xlAutomatic
                                                    .TintAndShade = 0
                                                    .PatternTintAndShade = 0
                                                End With
                                                With Selection.Interior
                                                    .Pattern = xlSolid
                                                    .PatternColorIndex = xlAutomatic
                                                    .ThemeColor = xlThemeColorDark1
                                                    .TintAndShade = 0
                                                    .PatternTintAndShade = 0
                                                End With
                                                With Selection
                                                    .HorizontalAlignment = xlLeft
                                                    .VerticalAlignment = xlCenter
                                                    .WrapText = False
                                                    .Orientation = 0
                                                    .AddIndent = False
                                                    .IndentLevel = 0
                                                    .ShrinkToFit = False
                                                    .ReadingOrder = xlContext
                                                    .MergeCells = False
                                                End With
                                                Selection.Font.Bold = False
                                                l = 0
                                     Else
                                         m = m + 1
                                         'MsgBox k
 
                                     End If
                                Else
                                l = 0
 
                                End If
                           Loop
 
                    End If
 
            Next
 
        i = i + 1
        Loop
        'MsgBox i
        'MsgBox j
        '
 
Next ws
 
'Cells(i, j).Select
 
End Sub

Je ne parle pas de crash à répétition avec l'erreur 1004 qui pop up de nul part avent que je ne redémarre visual basique

Et voici une version alléger de mon classeur

Bonjour,

D'accord. Ton code va mettre énormément de temps à tourner si tu le laisses tel quel. Il n'est pas du tout optimisé mais ça tu apprendras au fur et à mesure.

Alors pour répondre à ton problème de boucle. Tu select bien toutes tes feuilles avec ton for each. Le problème vient de ta variable I. Pour la première feuille ton I vaut 0 et tu fais une boucle While. Dans cette boucle While, à la fin, tu incrémentes I de 1.

Donc en fin de boucle ton I vaut finp et tu passes à la feuille suivante.

Tu vois où je veux en venir ?

À l'ouverture de la feuille suivante I vaut tours finp.... donc la boucle est hors jeu.
Pense à réinitialiser ton I à chaque nouvelle feuille.

De façon plus générale il y a beaucoup de points à améliorer (ne pas utiliser de select ni activate, utiliser des tableaux puis reporter ces tableaux d'un coup dans ta feuille test pour éviter les accès lecture écriture dans ton fichier, bloquer la mise à jour de l'écran qui demande du temps et de la ressource mémoire.....).

Mais au moins tu peux avancer en réinitialisant ton I.

1 pièce(s) jointe(s)

Voilà je t'ai créé en PJ un bout de code qui scanne les feuilles que tu précises dans la fonction appelante (tu peux également préciser feuille par feuille le nombre de lignes et colonnes à prendre en compte bien que ça aussi ça puisse être automatisé).

Je pense que tu as là une bonne base pour ton job même si mon code est lui aussi optimisable.

Il te suffit de cliquer sur le bouton de la feuille "test".

A toi d'adapter ensuite pour ton réel besoin.