tri code

[fourezizou]

bonjour a tous
je recherche une solution pour déplacé une plage qui indiqué par code et coller dans une nouveau feuille et renommer cette feuille comme le code sans utilise TCD.

 

[JCGL]

Re : tri code

Bonjour à tous,

Un essai avec ce code de.... :

Option Explicit

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

 

[fourezizou]

Re : tri code

Bonjour à tous,

Un essai avec ce code de.... :

Option Explicit

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

bonjour a tous ;JCGL
merci beaucoup çà marche bien