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 |
Partager