Discussion :

[kreutzberg]

Bonjour,

J'implore votre aide pour m'aider à construire une macro me permettant, à partir d'une liste d'outillages donnée par poste, de générer des feuilles de liste d'outillage propre à chaque poste et dont l'onglet porte le nom du poste.

De plus, j'aimerais qu'à chaque ouverture de ce fichier, que la liste de chaque onglet soit mise à jour automatiquement. La macro doit également permettre de générer un nouvel onglet pour l'ajout d'outillages sur un nouveau poste.

N'étant pas un spécialiste en la matière, cela me parait trop compliqué...

Je joins à ce message le fichier de la liste.

Merci par avance.

[BlueMonkey]

Bonsoir,

- Dans le projet VBA ajouter la référence "Microsoft scriptiong RunTime".

- Ajouter le code ci-dessous dans le code associé à ThisWorkbook.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Workbook_Open()
    UpdatePosteList
End Sub
 
Sub UpdatePosteList()
    Dim PosteListe As Dictionary
    Set PosteListe = New Dictionary
 
    Dim li As Long
    Dim wli As Long
    Dim activeWsName As String
 
    Application.ScreenUpdating = False
 
    Dim wsi As Integer
    For wsi = 2 To Worksheets.Count
        PosteListe.Add Worksheets(wsi).Name, Worksheets(wsi).Name
    Next wsi
 
    For li = 2 To Range("B" & Rows.Count).End(xlUp).Row
        With Worksheets(1).Cells(li, 2)
            ' création de la feuille poste si nécessaire
            If Not PosteListe.Exists(.Value) Then
                Call PosteListe.Add(.Value, .Value)
                Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = .Value
                With Worksheets(.Value)
                    .Cells(1, 1) = Worksheets(1).Cells(1, 3)
                    .Cells(1, 2) = Worksheets(1).Cells(1, 4)
                    .Cells(1, 3) = Worksheets(1).Cells(1, 5)
                    .Cells(1, 4) = Worksheets(1).Cells(1, 6)
                End With
            End If
 
            ' création de la feuille poste si nécessaire
            With Worksheets(.Value)
                If activeWsName <> .Name Then
                    activeWsName = .Name
                    wli = .Range("A" & Rows.Count).End(xlUp).Row
                End If
 
                Dim i As Long
                Dim OutilExist As Boolean
                OutilExist = False
                For i = 1 To wli
                    If .Cells(i, 1).Value = Worksheets(1).Cells(li, 3) Then
                        OutilExist = True
                        i = wli
                    End If
                Next i
 
                If Not OutilExist Then
                    wli = wli + 1
                    .Cells(wli, 1) = Worksheets(1).Cells(li, 3)
                    .Cells(wli, 2) = Worksheets(1).Cells(li, 4)
                    .Cells(wli, 3) = Worksheets(1).Cells(li, 5)
                    .Cells(wli, 4) = Worksheets(1).Cells(li, 6)
                End If
            End With
        End With
    Next li
 
    Worksheets(1).Activate
    Application.ScreenUpdating = True
 
End Sub

[kreutzberg]

Le code fonctionne bien, je vous remercie