Bonjour,
Le code ci-dessous me permet de ventiler ma feuil1 sur plusieurs feuilles. Par contre au moment du coller dans chaque onglet, la ligne 1 reste vide et le contenu se colle à partir de la ligne 2.
Dim CurCell As Range
Application.ScreenUpdating = False
Columns("A:BQ").Sort Key1:=Range("D1"), Order1:=xlAscending, Key2:=Range("B1"), Order2:=xlAscending, Header:=xlGuess
Range("A1").Select
Set CurCell = ThisWorkbook.Sheets("Feuil1").Range("D1")
While CurCell.Value <> vbNullString
With GetSheet(CurCell.Value)
CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
Set CurCell = CurCell.Offset(1, 0)
Columns("A:BQ").Columns.AutoFit
Wend
Application.DisplayAlerts = 1
Sheets("Feuil1").Activate
End Sub
Public Function GetSheet(SheetName As String) As Worksheet
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
Pourriez-vous m'aider svp.
Merci
Gabo29
Le code ci-dessous me permet de ventiler ma feuil1 sur plusieurs feuilles. Par contre au moment du coller dans chaque onglet, la ligne 1 reste vide et le contenu se colle à partir de la ligne 2.
Dim CurCell As Range
Application.ScreenUpdating = False
Columns("A:BQ").Sort Key1:=Range("D1"), Order1:=xlAscending, Key2:=Range("B1"), Order2:=xlAscending, Header:=xlGuess
Range("A1").Select
Set CurCell = ThisWorkbook.Sheets("Feuil1").Range("D1")
While CurCell.Value <> vbNullString
With GetSheet(CurCell.Value)
CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
Set CurCell = CurCell.Offset(1, 0)
Columns("A:BQ").Columns.AutoFit
Wend
Application.DisplayAlerts = 1
Sheets("Feuil1").Activate
End Sub
Public Function GetSheet(SheetName As String) As Worksheet
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
Pourriez-vous m'aider svp.
Merci
Gabo29