Extraire des lignes complètes de données

'Ti http://www.veriti.net
'février 2008
Option Explicit

Private Sub CreeFeuille(ByVal Groupe$, Plage As Range)
Dim Cel As Range, Dest As Range, Ws As Worksheet
  On Error Resume Next
  With ThisWorkbook
      Set Ws = .Worksheets(Groupe)
    If Not Ws Is Nothing Then Exit Sub
    Set Ws = .Worksheets.Add(, .Worksheets(.Worksheets.Count))
  End With
  With Ws
    .Name = Groupe
    .Range("A1:D1") = Array("Numéro", "Groupe", "Somme", "Rachat")
    Set Dest = .Range("A2")
    For Each Cel In Plage
      If Cel = Groupe Then
        Cel(1, 0).Resize(, 4).Copy Dest
        Set Dest = Dest.Offset(1, 0)
      End If
    Next Cel
  End With
End Sub

Sub CreeDEC()
Dim Ws As Worksheet, Plage As Range, Cel As Range
Dim Col As Collection, Groupe
  On Error Resume Next
 Application.ScreenUpdating = False
  Set Ws = ThisWorkbook.Worksheets("Data")
  With Ws
    Set Plage = .Range("B2", .Range("B65536").End(xlUp))
  End With
  Set Col = New Collection

  For Each Cel In Plage
    Col.Add Cel, CStr(Cel)
  Next Cel
  For Each Groupe In Col
    CreeFeuille Groupe, Plage
  Next Groupe
  Ws.Activate
  Application.ScreenUpdating = True
End Sub

Sub feuille_par_nom()
Application.ScreenUpdating = False
Dim Cel As Range, Noms As Object, Itm
Dim DerLig As Long
Set Noms = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    DerLig = .[A65000].End(xlUp).Row
    .Range("A1:H" & DerLig).Name = "mabase"
    For Each Cel In .Range("A2:A" & DerLig)
        If Not Noms.Exists(Cel.Value) Then Noms.Add Cel.Value, Cel.Value
    Next Cel
    .[IV1] = .[A1]
    For Each Itm In Noms.items
        .[IV2] = Itm
        On Error Resume Next
        If Sheets(Itm).Range("A1").Value = .Range("A1").Value Then
            If Err.Number <> 9 Then
                Range("mabase").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
                    .Range("IV1:IV2"), CopyToRange:=Sheets(Itm).Range("A1:H1"), Unique:=False
            Else
                Sheets.Add.Name = Itm
                [A1:H1].Value = .[A1:H1].Value
                Range("mabase").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
                    .Range("IV1:IV2"), CopyToRange:=Range("A1:H1"), Unique:=False
            End If
        End If
    Next Itm
.Columns(256).Delete Shift:=xlToLeft
End With