Extraire données l'une liste

Jean-Eric, c'est exactement le tableau qu'il me faut.

Lorsque je transfert le code,

Set lo = wsData.ListObjects(1)  'l'indice n’appartiens pas a la sélection, que dois-je faire ?

Les lignes contenant Lot ## en fin de phrase sont prise en compte dans lot Autres,

exemple : Sous-total modification salle de crise au RDC Lot ##,

Est-il possible de les affecter au lot concerné ?

Maintenant je suis bloqué sur :

Select Case UCase(x(2))

Bonjour,

Voir la mise à jour.

Cdlt.

nota : tes données doivent mis en tableau.

Bonjour,

J'ai toujours un bug au même endroit

Select Case UCase(x(2)), que signifie cette commande ?

Bonjour,

Clique 2 fois sur le terme Ucase et appuie sur F1.

Cdlt.

Bonsoir à tous,

Nuage75, j'ai défini les clés du dictionnaire via les expressions réguliéres (RegExp).

Option Explicit

Sub test()
Dim dico As Object, RegX As Object, i As Long, e, n As Long, txt As String
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Global = False
        .IgnoreCase = True
        .Pattern = "lots* ?(\d+)"
    End With
    With Sheets(1).Range("a1").CurrentRegion    'Feuil2
        For i = 2 To .Rows.Count
            If RegX.test(.Cells(i, 4).Value) Then
                txt = "Lot " & Format(RegX.Execute(.Cells(i, 4).Value)(0).submatches(0), "0")
            Else
                txt = "autres"
            End If
            If Not dico.exists(txt) Then
                If i = 2 Then
                    Set dico(txt) = Union(.Rows(1), .Rows(i))
                Else
                    Set dico(txt) = .Rows(i)
                End If
            Else
                Set dico(txt) = _
                Union(dico(txt), .Rows(i))
            End If
        Next
    End With
    'Restitution et mise en forme
    With Sheets(2)    'Feuil3
        .Cells.Clear
        For Each e In dico
            n = n + 1
            dico(e).Copy
            .Cells(n, 1).PasteSpecial xlPasteValues
            With .Cells(n, 1).CurrentRegion
                With .Offset(.Rows.Count).Resize(1, 9)
                    With .Columns("a:i")
                        If n = 1 Then
                            .Value = Array("", "", "", "TOTAL " & e, _
                                           "=sum(r" & n + 1 & "c:r[-1]c)", "", "", _
                                           "=sum(r" & n + 1 & "c:r[-1]c)", "")
                        Else
                            .Value = Array("", "", "", "TOTAL " & e, _
                                           "=sum(r" & n & "c:r[-1]c)", "", "", _
                                           "=sum(r" & n & "c:r[-1]c)", "")
                        End If
                        With .Offset(, 3).Resize(, 6)
                            .VerticalAlignment = xlCenter
                            .BorderAround Weight:=xlThin
                            .Borders(xlInsideVertical).Weight = xlThin
                            .Interior.ColorIndex = 36
                        End With
                    End With
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .VerticalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                If n = 1 Then
                    With .Rows(1)
                        .BorderAround Weight:=xlThin
                        .Interior.ColorIndex = 38
                    End With
                End If
                n = n + .Rows.Count + 1
            End With
        Next
        .Columns.AutoFit
        .Activate
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

klin89