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
| Option Explicit
Sub Empilement()
Dim f1 As Worksheet, f2 As Worksheet
Dim i As Long, DerCol_f1 As Long, DerLig_f1 As Long, DerLig_f2 As Long, DerCol_f2 As Long, DerLig_Mes As Long, Lig_f2 As Long, Col_f2 As Long, c As Long, Nb_Lig As Long, k As Long
Dim m As Range, cell As Range
Dim d As Object
Dim Couleur As Long, Couleur1 As Long, Couleur2 As Long
Application.ScreenUpdating = False
Set f1 = Sheets("BDD")
Set f2 = Sheets("Synthese")
f2.Cells.Clear
Set d = CreateObject("Scripting.Dictionary")
DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
Col_f2 = 2
For i = 1 To DerLig_f1
Lig_f2 = 2
With f1.Range("A1:A" & DerLig_f1)
Set m = .Find("mesure " & i, lookat:=xlWhole)
If Not m Is Nothing Then
DerCol_f1 = f1.Cells(m.Row, 1).End(xlToRight).Column
DerLig_Mes = f1.Cells(m.Row, "B").End(xlDown).Row
For c = DerCol_f1 To 2 Step -1
For Each cell In Range(f1.Cells(m.Row + 1, c), f1.Cells(DerLig_Mes, c))
d.Add cell, ""
Next cell
f2.Cells(Lig_f2, Col_f2).Resize(d.Count, 1) = Application.Transpose(d.keys)
Lig_f2 = Lig_f2 + d.Count
d.RemoveAll
Next c
f2.Cells(1, Col_f2) = "Mesure " & i
Col_f2 = Col_f2 + 1
End If
End With
Next i
'remplissage de la première colonne avec la position des relevés par ligne
With f1.Range("A1:A" & DerLig_f1)
Set m = .Find("mesure 1", lookat:=xlWhole)
DerLig_Mes = f1.Cells(m.Row, "B").End(xlDown).Row
DerCol_f2 = f2.Cells(2, 2).End(xlToRight).Column
DerLig_f2 = f2.Columns("B").Find(what:="*", searchdirection:=xlPrevious).Row
'Séparation des tranches de relevés par une alternance de couleurs
Nb_Lig = DerLig_Mes - m.Row
Couleur1 = 43
Couleur2 = 4
For k = 2 To DerLig_f2 Step Nb_Lig
For i = 1 To DerLig_Mes 'Nb_Lig
If f2.Cells(k + i - 1, "B") <> "" Then f2.Cells(k + i - 1, "A") = "Ligne " & i
Next i
If Couleur = Couleur1 Then Couleur = Couleur2 Else: Couleur = Couleur1
Range(f2.Cells(k, 1), f2.Cells(k + Nb_Lig - 1, DerCol_f2)).Interior.ColorIndex = Couleur
Next k
End With
Set m = Nothing
Set f1 = Nothing
Set f2 = Nothing
End Sub |
Formules Excel en VBA
Répondre avec citation
Partager