VBA Insérer des tableaux dans un tableau

Version imprimable

15/02/2020, 20h48
BosonDeH

1 pièce(s) jointe(s)

VBA Insérer des tableaux dans un tableau

Bonjour cher Forum,
Je joins à ce message un fichier excel Exemple pour mieux illustrer ma demande d'aide.
J'ai un code VBA (très simple) que je souhaite améliorer, pour le problème suivant

J'ai un tableau sur une feuille 1, ce tableau reprend des informations concernant des acteurs (ACTOR ID) et une série des caractéristiques, chaque acteur est repris une fois.

J'ai un deuxième tableau sur une feuille 2 qui reprend des informations pour les acteurs mais cette fois les acteurs sont répétés au tant de fois qu'ils ont des produits différents ( product lab).

Et j'ai, un code qui permet d'intégrer les informations du second tableau dans le premier en créant pour chaque acteur, des sous lignes qui détaillent les informations colonnes. (Une sorte de décomposition de ACTOR ID), le résultat est obtenu sur la feuille "Résultat".
Je souhaite améliorer mon code pour avoir la même sortie que sur la feuille 3, c'est à dire quand on ouvre un acteur ID on voit aussi les titres.

Ps : le nombre ligne de chaque tableau n'est pas connu en avance.

Merci

Bonjour,

Essayez ceci

Code:

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
Option Explicit
 
Public Sub MAJ()
    Dim oSh1 As Worksheet
    Dim oSh2 As Worksheet
    Dim oShRes As Worksheet
    Dim iLig1 As Integer
    Dim iDerLig1 As Integer
    Dim iLig2 As Integer
    Dim iDerLig2 As Integer
    Dim iDerLig3 As Integer
    Dim iEcr As Integer
    Dim iDeb As Integer
    Dim iFin As Integer
    Set oSh1 = Worksheets("Feuil1")
    Set oSh2 = Worksheets("Feuil2")
    Set oShRes = Worksheets("Resultat")
    'dégroupe
    On Error Resume Next
    oShRes.Rows.Rows.Ungroup
    On Error GoTo 0
    iDerLig1 = oSh1.Range("B" & Rows.Count).End(xlUp).Row
    iDerLig2 = oSh2.Range("B" & Rows.Count).End(xlUp).Row
    iDerLig3 = oShRes.Range("B" & Rows.Count).End(xlUp).Row
    oShRes.Range(Cells(4, "B"), Cells(iDerLig3, "H")).Clear 'on efface les précédents résultats
    iEcr = 4
    For iLig1 = 5 To iDerLig1
        iDeb = -1
        iFin = -1
        oShRes.Range("B" & iEcr & ":H" & iEcr).Value = oSh1.Range("B" & iLig1 & ":H" & iLig1).Value
        oShRes.Range("B" & iEcr + 1 & ":H" & iEcr + 1) = Array("PRODUCT LAB.", "ACTOR NAME", "ACTOR SEG", "PNB", "E.V.A", "R.W.A", "Rating")
        oShRes.Range("B" & iEcr + 1 & ":H" & iEcr + 1).Interior.Color = RGB(217, 226, 243)
        iEcr = iEcr + 2
        For iLig2 = 5 To iDerLig2
            If oSh2.Range("B" & iLig2).Value = oSh1.Range("B" & iLig1).Value Then
                If iDeb = -1 Then
                    iDeb = iEcr
                End If
                iFin = iEcr
                'ACTOR ID
                oShRes.Range("B" & iEcr).Value = oSh2.Range("G" & iLig2).Value
                'ACTOR NAME
                oShRes.Range("C" & iEcr).Value = oSh1.Range("C" & iLig1).Value
                'ACTOR SEG
                oShRes.Range("D" & iEcr).Value = oSh1.Range("D" & iLig1).Value
                'PNB
                oShRes.Range("E" & iEcr).Value = oSh2.Range("C" & iLig2).Value
                'E.V.A
                'R.W.A
                'Rating
                'ligne suivante
                iEcr = iEcr + 1
            End If
        Next iLig2
        'regroupe
        If iDeb <> -1 And iFin <> -1 Then
            oShRes.Rows(iDeb & ":" & iFin).Rows.Group
        End If
    Next iLig1
    Set oSh1 = Nothing
    Set oSh2 = Nothing
    Set oShRes = Nothing
    'Sheets("feuil2").Visible = xlVeryHidden
End Sub

Cdlt

16/02/2020, 18h21
BosonDeH

Merci Beaucoup ARTURO83