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
| Sub remplissage1()
Dim finp As Long
Dim nb As Long, i As Long, j As Long, Finl As Long
Dim nb2 As Long
Dim nb1 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 Object 'Worksheet
'("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
tws = Array("Energie 1")
nb2 = 1 'Conteur Data
j = 5 'conteur de colone
i = 1 'conteur de ligne
finp = 15 '700 ' profondeur/ligne
Finl = 43 'longueur/colonne
nb = j
nb1 = i
ws = Sheets("Energie 1")
o = ws.Name
For Each ws In Worksheets(tws)
' ws = Sheets("Energie 1")
o = ws.Name
For i = nb1 To finp
For j = nb To Finl Step 1
X = False: On Error Resume Next 'conteur de choix multiple
X = ws.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
ws.Cells(i, j).Select
If Not y = 11111 And Cells(i, j) = "" And Not Left(Cells(i, j).Formula, 1) = "=" And Not Cells(i, j).MergeCells And IsNumeric(Cells(i, j)) Then
If Cells(i, j).Borders(xlEdgeLeft).LineStyle = xlContinuous And Cells(i, j).Borders(xlEdgeBottom).LineStyle = xlContinuous And Cells(i, j).Borders(xlEdgeTop).LineStyle = xlContinuous And Cells(i, j).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
For k = 1 To i - 1
ws.Cells(i - k, j).Select
If WorksheetFunction.IsText(ws.Cells(i - k, j)) And ws.Cells(i - k, j).Borders(xlEdgeLeft).LineStyle = xlContinuous And ws.Cells(i - k, j).Borders(xlEdgeRight).LineStyle = xlContinuous And ws.Cells(i - k, j).Borders(xlEdgeTop).LineStyle = xlContinuous Then
Sheets("test").Cells(5, nb2) = ws.Cells(i - k, j) ' Bordure sup
k = i - 1
ElseIf WorksheetFunction.IsText(ws.Cells(i - k, j)) And ws.Cells(i - k, j).Borders(xlEdgeLeft).LineStyle = xlContinuous And ws.Cells(i - k, j).Borders(xlEdgeBottom).LineStyle = xlContinuous And ws.Cells(i - k, j).Borders(xlEdgeRight).LineStyle = xlContinuous And ws.Cells(i - k, j).Borders(xlEdgeTop).LineStyle = xlContinuous And Not i = k Then
Sheets("test").Cells(5, nb2) = ws.Cells(i - k, j) 'contoure
k = i - 1
ElseIf WorksheetFunction.IsText(ws.Cells(i - k, j)) And ws.Cells(i - k, j).Borders(xlEdgeLeft).LineStyle = xlContinuous And ws.Cells(i - k, j).Borders(xlEdgeRight).LineStyle = xlContinuous Then
Sheets("test").Cells(6, nb2) = ws.Cells(i - k, j) 'bordure inf
End If
Next k
Sheets("test").Cells(7, nb2) = ws.Cells(i, 2) 'Récupération du titre de ligne
For n = 1 To i - 1 'Récupération du titre du tableau
ws.Cells(i - n, 2).Select
If WorksheetFunction.IsText(ws.Cells(i - n, 2)) And ws.Cells(i - n, 2).Borders(xlEdgeLeft).LineStyle = xlContinuous And ws.Cells(i - n, 2).Borders(xlEdgeTop).LineStyle = xlContinuous And ws.Cells(i - n - 1, 2) = "" Then
Sheets("test").Cells(8, nb2) = ws.Cells(i - n, 2)
n = i - 1
End If
Next n
For m = 1 To i - 1 'Récupération du titre de catégorie
ws.Cells(i - m, j).Select
If Selection.MergeCells = True And ws.Cells(i - m + 1, j) = "" And ws.Cells(i - m - 1, j) = "" Then 'And ws.Cells(i - m, j).Borders(xlEdgeLeft).LineStyle = xlContinuous And ws.Cells(i - m, j).Borders(xlEdgeBottom).LineStyle = xlContinuous And ws.Cells(i - m, j).Borders(xlEdgeRight).LineStyle = xlContinuous And ws.Cells(i - m, j).Borders(xlEdgeTop).LineStyle = xlContinuous And ws.Cells(i - m + 1, j) = "" And ws.Cells(i - m - 1, j) = "" Then
ws.Select
Selection.Copy
Sheets("test").Select
Cells(9, nb2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
Selection.Font.Bold = False
With Selection.Font
.Name = "Arial"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.UnMerge
m = i - 1
End If
Next m
End If
End If
Next j
Next i
'MsgBox i
'MsgBox j
'
Next ws
'Cells(i, j).Select
End Sub |
Erreur 91 , erreur incompréhensible
Répondre avec citation
Partager