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
| Sub extraireDonneesCellule()
Dim Cell As Range
Dim i As Integer, j As Integer
Dim x As Byte
Dim Un As New Collection
Dim Ws As Worksheet
'liste les noms d'agence sans doublons
On Error Resume Next
For Each Cell In Sheets("Feuil1").Range("A2:A" & Sheets("Feuil1").Range("A65536").End(xlUp).Row)
Un.Add Cell, CStr(Cell)
Next Cell
On Error GoTo 0
Application.ScreenUpdating = False
'cree les onglets à partir de la liste sans doublons
For i = 1 To Un.Count
Worksheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Un(i)
Next i
'transfert des données dans chaque feuille créée
For Each Cell In Sheets("Feuil1").Range("A2:A" & Sheets("Feuil1").Range("A65536").End(xlUp).Row)
Set Ws = Worksheets(Cell.Value)
j = Ws.Range("A65536").End(xlUp).Row + 1
For x = 1 To 5
Ws.Cells(j, x) = Cell.Offset(0, x)
Next x
Set Ws = Nothing
Next Cell
Application.ScreenUpdating = True
End Sub |