Tableau dynamique à partir de deux tableaux
Bonjour,
je joint un fichier sur lequel je met en l'état deux tableaux que l'on me transmet. Ils sont sur ma feuill1.
Sachant que l'on retrouvera forcement tous les noms du tableau de gauche (le plus gros) dans le tableau de droite. Parcontre le tableau de droite peut avoir des noms en plus (c'est le cas dans mon exemple avec PAUL MOY, PATRICIA POT, MIREILLE DOL et FRANCK JU
en plus).
Mon but est de trouver la manière la plus efficace et plus rapide de faire un condensé des deux tableaux. Dans le style de tableau que j'ai mis en feuill3. Soit de façon dynamique ou par macro. Quel que soit le nombre de nom dans les tableau je voudrais automatiser tout ça car actuellement je perd énormément de temps
Vous pourriez me dire que les tableaux de ma feuill1 sont mal conçu, effectivement, malheureusement il m'est obligatoire de composer avec ça, ils auront tjs la même forme, la seule donnée qui change est le nombre de nom d'Agent.
Si quelqu'un pouvais m'aider ça serait génial
par avance merci
bonne soirée
Eno
Bonsoir Eno83,
A tester :
Restitution en Feuil2.
Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long
With Sheets("Feuil1").Range("a12").CurrentRegion
a = .Value: n = 2
'Attention à la 1ère dimension
ReDim b(1 To 100, 1 To 13)
For i = 1 To UBound(a, 2)
b(n, i) = a(1, i)
Next
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1) - 2
If a(i, 1) = "" Then a(i, 1) = a(i - 1, 1)
If Not .exists(a(i, 1)) Then
n = n + 2
For j = 1 To 9
b(n - 1, j) = a(i, j)
Next
.Item(a(i, 1)) = n
Else
For j = 2 To 9
b(.Item(a(i, 1)), j) = a(i, j)
Next
End If
Next
a = Sheets("Feuil1").Range("m12").CurrentRegion.Value
b(1, 10) = a(1, 2): b(1, 12) = a(1, 4)
For i = 2 To UBound(a, 2)
b(2, i + 8) = a(2, i)
Next
For i = 3 To UBound(a, 1) - 1
If .exists(a(i, 1)) Then
For j = 2 To UBound(a, 2)
b(.Item(a(i, 1)) - 1, j + 8) = a(i, j)
Next
Else
n = n + 1
b(n, 1) = a(i, 1)
For j = 2 To UBound(a, 2)
b(n, j + 8) = a(i, j)
Next
End If
Next
n = n + 2
b(n - 1, 1) = "Total"
b(n - 1, 2) = "Manuel": b(n, 2) = "Vérification des réponses"
End With
End With
Application.ScreenUpdating = False
'Restitution
With Sheets("Feuil2").Cells(1).Resize(n, UBound(b, 2))
.CurrentRegion.Clear
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
With .Offset(1).Resize(.Rows.Count - 1)
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Columns(1).HorizontalAlignment = xlCenter
With .Rows(1)
.VerticalAlignment = xlTop
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 36
.RowHeight = 39
.BorderAround Weight:=xlThin
End With
End With
.Columns.AutoFit
With .Rows(1).Offset(, 9).Resize(, .Columns.Count - 9)
.Interior.ColorIndex = 36
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
.Cells(1).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
.Cells(3).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
End With
End With
Application.ScreenUpdating = True
End Sub
klin89
Bonjour Klin!
Je viens de tester et ça me convient parfaitement
Je te remercie pour le temps passé à m aider
Bonne fin de journée
Re Eno83
Comme ceci, le rendu est similaire au résultat souhaité.
Option Explicit
Sub Test()
Dim a, b(), i As Long, j As Long, n As Long, w(), z(), x, y
a = Sheets("Feuil1").Range("m12").CurrentRegion.Value
ReDim b(1 To 2, 1 To 13)
b(1, 10) = a(1, 2): b(1, 12) = a(1, 4): b(2, 10) = a(2, 2)
b(2, 11) = a(2, 3): b(2, 12) = a(2, 4): b(2, 13) = a(2, 5)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 3 To UBound(a, 1) - 1
ReDim w(1 To 2): ReDim z(1 To 13, 1 To 1)
z(1, 1) = a(i, 1)
For j = 2 To UBound(a, 2)
z(j + 8, 1) = a(i, j)
Next
w(1) = False: w(2) = z
.Item(a(i, 1)) = w
Next
a = Sheets("Feuil1").Range("a12").CurrentRegion.Value
For i = 1 To UBound(a, 2): b(2, i) = a(1, i): Next
For i = 2 To UBound(a, 1) - 2
If a(i, 1) = "" Then a(i, 1) = a(i - 1, 1)
If .exists(a(i, 1)) Then
w = .Item(a(i, 1))
z = w(2)
If w(1) = False Then
w(1) = True
Else
ReDim Preserve z(1 To 13, 1 To UBound(z, 2) + 1)
End If
For j = 2 To 9
z(j, UBound(z, 2)) = a(i, j)
Next
w(2) = z
.Item(a(i, 1)) = w
End If
Next
x = .keys: y = .items
End With
Application.ScreenUpdating = False
'Restitution et mise en forme
With Sheets("Feuil2").Cells(1)
.Parent.Cells.Clear
.Resize(UBound(b, 1), UBound(b, 2)).Value = b
n = 2
For i = 0 To UBound(x)
With .Offset(n).Resize(UBound(y(i)(2), 2), UBound(y(i)(2), 1))
.Value = Application.Transpose(y(i)(2))
If y(i)(1) = True Then
.Columns(1).MergeCells = True
For j = 10 To 13
.Columns(j).MergeCells = True
Next
Else
.Rows.Interior.ColorIndex = 40
End If
.BorderAround Weight:=xlMedium
.Borders(xlInsideHorizontal).Weight = xlThin
n = n + .Rows.Count
End With
Next
With .CurrentRegion
.Font.Name = "calibri": .Font.Size = 10
.VerticalAlignment = xlCenter
With .Rows(1).Offset(, 9).Resize(, .Columns.Count - 9)
.RowHeight = 39: .Interior.ColorIndex = 36
.WrapText = True: .BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Cells(1).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
.Cells(3).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
End With
With .Rows(2)
.RowHeight = 45: .Interior.ColorIndex = 36
.WrapText = True: .BorderAround Weight:=xlMedium
End With
With .Offset(1).Resize(.Rows.Count - 1)
.Borders(xlInsideVertical).Weight = xlMedium
End With
With .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
.HorizontalAlignment = xlCenter
End With
.Columns.ColumnWidth = Array(14, 24, 11, 11, 11, _
11, 11, 11, 11, 11, 11, 11, 11)
End With
End With
Application.ScreenUpdating = True
End Sub
klin89
Coucou, merci!!
Parfait
Merci pour ton aide
Bonne journée