Sub Test()
Dim CurCell As Range, Titre As Range
Application.ScreenUpdating = 0
Columns("A:C").Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlGuess
Range("A1").Select
Set CurCell = ThisWorkbook.Sheets("Data").Range("A1")
Set Titre = ThisWorkbook.Sheets("Data").Range("A1:C1")
While CurCell.Value <> vbNullString
With GetSheet(CurCell.Value)
Titre.EntireRow.Copy .Cells(1, 1)
CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
Set CurCell = CurCell.Offset(1, 0)
Columns("A:J").Columns.AutoFit
Wend
Application.DisplayAlerts = 0
Sheets("Code").Delete
Application.DisplayAlerts = 1
Sheets("Data").Activate
End Sub
Public Function GetSheet(SheetName As String) As Worksheet
'cette fonction renvoie la feuille nommée <SheetName> et la crée si elle n'existe pas
Dim CurSheet As Worksheet, exist As Boolean
exist = False
For Each CurSheet In ThisWorkbook.Sheets
If CurSheet.Name = SheetName Then exist = True
Next CurSheet
If Not exist Then
ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SheetName
End If
Set GetSheet = ThisWorkbook.Worksheets(SheetName)
End Function
bonjour a tous ;JCGLBonjour à tous,
Un essai avec ce code de.... :
Option Explicit
VB:Sub Test() Dim CurCell As Range, Titre As Range Application.ScreenUpdating = 0 Columns("A:C").Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlGuess Range("A1").Select Set CurCell = ThisWorkbook.Sheets("Data").Range("A1") Set Titre = ThisWorkbook.Sheets("Data").Range("A1:C1") While CurCell.Value <> vbNullString With GetSheet(CurCell.Value) Titre.EntireRow.Copy .Cells(1, 1) CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) End With Set CurCell = CurCell.Offset(1, 0) Columns("A:J").Columns.AutoFit Wend Application.DisplayAlerts = 0 Sheets("Code").Delete Application.DisplayAlerts = 1 Sheets("Data").Activate End Sub Public Function GetSheet(SheetName As String) As Worksheet 'cette fonction renvoie la feuille nommée <SheetName> et la crée si elle n'existe pas Dim CurSheet As Worksheet, exist As Boolean exist = False For Each CurSheet In ThisWorkbook.Sheets If CurSheet.Name = SheetName Then exist = True Next CurSheet If Not exist Then ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SheetName End If Set GetSheet = ThisWorkbook.Worksheets(SheetName) End Function
A + à tous