Re : repartition de donnée
Bonjour,
pour "splitter" en onglet, tu peux essayer ceci et puis tu renommes
Sub SplitEnOnglets()
Dim rngdelete2 As Range
Dim rng2 As Range, Vides As Integer
Dim Le_parametre As Boolean
Dim LastrowC As Integer
Dim Titre, TotClass, TotGene, Colonne, mLong
Dim Zone
Application.ScreenUpdating = False
' nommer les colonnes
Application.DisplayAlerts = False
Range("A1").Select
Selection.CurrentRegion.Select
Selection.CreateNames Top:=True, Left:=False, Bottom:=False, Right:=False
Application.DisplayAlerts = True
' tri sur la colonne choisie
LastrowC = Range("C65000").End(xlUp).Row
Colonne = Range("C:C").Column
mLong = IIf(Colonne <= 26, 4, 5)
Set Zone = Range("C2:C" & LastrowC)
Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
With ActiveSheet
For Each rng2 In Zone
If rng2.Value = "" Then Vides = Vides + 1: GoTo Suivant ' rng2.Value = "SANS NOM"
Le_parametre = UCase(rng2.Value) = UCase(rng2.Offset(1, 0).Value)
If Not Le_parametre Then
If rngdelete2 Is Nothing Then
Set rngdelete2 = rng2.EntireRow
Else
Set rngdelete2 = Union(rngdelete2, rng2.EntireRow)
End If
Set Titre = Range("1:1")
Sheets.Add
ActiveWindow.Zoom = 110
Titre.Copy
Range("A1").PasteSpecial
ActiveSheet.Name = rng2.Value
If Not rngdelete2 Is Nothing Then
rngdelete2.EntireRow.Copy ActiveSheet.Range("A2")
TotClass = ActiveSheet.UsedRange.Rows.Count - 1 ' ne pas compter le titre
TotGene = TotGene + TotClass
Set rngdelete2 = Nothing
GoTo Suivant
End If
Else
If rngdelete2 Is Nothing Then
Set rngdelete2 = rng2.EntireRow
Else
Set rngdelete2 = Union(rngdelete2, rng2.EntireRow)
End If
End If
Suivant:
Next rng2
End With
End Sub
P.