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
|
Option Explicit
Sub recap2()
Dim Sources, Champs, oSrc, oEqu
Dim i&, j&, k&, uoEqu2&, uChamps1&, uChamps2&
'
With Sheets("RECAP2") 'Feuille de destination
Sources = Array("Feuil9", "Feuil10", "Feuil11") 'Données à regrouper
Champs = .Range("A1").Resize(1, .Range("A1").End(xlToRight).Column).Value 'Intitulés des champs de la feuille RECAP1
Champs = WorksheetFunction.Transpose(Champs)
uChamps1 = UBound(Champs, 1)
For i = 0 To UBound(Sources)
oSrc = Sheets(Sources(i)).Range("A1").CurrentRegion.Value
ReDim oEqu(1 To 2, 1 To 1)
For j = 1 To UBound(oSrc, 2)
For k = 1 To uChamps1
If oSrc(1, j) = Champs(k, 1) Then
ReDim Preserve oEqu(1 To 2, 1 To 1 + UBound(oEqu, 2))
oEqu(1, UBound(oEqu, 2)) = k
oEqu(2, UBound(oEqu, 2)) = j
End If
Next k
Next j
uoEqu2 = UBound(oEqu, 2)
For j = 2 To UBound(oSrc, 1)
ReDim Preserve Champs(1 To uChamps1, 1 To 1 + UBound(Champs, 2))
uChamps2 = UBound(Champs, 2)
For k = 2 To uoEqu2
Champs(oEqu(1, k), uChamps2) = oSrc(j, oEqu(2, k))
Next k
Next j
Next i
Champs = WorksheetFunction.Transpose(Champs)
.Range("A1").Resize(.Rows.Count, uChamps1).ClearContents
.Range("A1").Resize(uChamps2, uChamps1).Value = Champs
End With
End Sub |
