tri code

fourezizou

XLDnaute Occasionnel
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.
 

Fichiers joints

JCGL

XLDnaute Barbatruc
Re : tri code

Bonjour à 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
 

Fichiers joints

Dernière édition:

fourezizou

XLDnaute Occasionnel
Re : tri code

Bonjour à 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
bonjour a tous ;JCGL
merci beaucoup çà marche bien
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas