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
|
Option Explicit
Sub Empilement()
Dim F1 As Worksheet, F2 As Worksheet
Dim i As Long, DerCol_f1 As Long, DerCol 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, L As Long
Dim m As Range, cell As Range
Dim d As Object
Application.ScreenUpdating = False
Set F1 = Sheets("BDD")
Set F2 = Sheets("Synthese")
F2.Cells.Clear
'Concatenation et positionnement du terme mesure x
DerLig_f1 = F1.Cells(Rows.Count, 1).End(xlUp).Row
'Application.ScreenUpdating = False
For i = 1 To DerLig_f1
If F1.Cells(i, "A") Like "Mesure:" Then
F1.Cells(i + 16, "A") = F1.Cells(i, "A") & F1.Cells(i, "B")
End If
Next i
'sélection et transposition des données de colonnes Feuille 1 à lignes Feuille 2
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 = 13
With F1.Range("A1:A" & DerLig_f1)
Set m = .Find("Mesure:" & i, lookat:=xlWhole)
'identification de la plage de données et enregistrement du NB de colonne
If Not m Is Nothing Then
DerCol_f1 = F1.Cells(m.Row + 1, 16384).End(xlToLeft).Column
DerLig_Mes = F1.Cells(m.Row + 1, "B").End(xlDown).Row
For c = DerCol_f1 To 1 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) = i
Col_f2 = Col_f2 + 1
End If
End With
Next i
'remplissage de la première colonne avec la position des données 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
End With
'récupération des heures de relevées des données
F2.Cells(2, 1) = "Heure :"
L = 2
DerLig_f1 = F1.Cells(Rows.Count, 1).End(xlUp).Row
'Application.ScreenUpdating = False
For i = 1 To DerLig_f1
If F1.Cells(i, "A") Like "Heure:" Then
F1.Cells(i, "B").Copy
F2.Cells(2, L).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
F2.Cells(2, L).NumberFormat = "[$-F400]h:mm:ss AM/PM"
End If
If F2.Cells(2, L) <> "" Then L = L + 1
Next i
Set m = Nothing
Set F1 = Nothing
Set F2 = Nothing
End Sub |
