creer des onglet a partir de ligne

[FREDPLONGEUR]

Bonjour forum,
J'essaye avec la macro ci-dessous etle fichier joint de creer autant d'onglet que de famille
en recopiant les lignes correspondante dedans puis un classement dans chaque onglet par fournisseur
Peut on optimiser cette macro ?
Sub test()

'Programme qui cree les onglets
Sheets(2).Select
Sheets.Add.Name = "aut"
Sheets.Add.Name = "cac"
Sheets.Add.Name = "feu"
Sheets.Add.Name = "vid"
Sheets.Add.Name = "int"
Sheets.Add.Name = "tal"
Sheets.Add.Name = "son"
Sheets.Add.Name = "inf"
Sheets.Add.Name = "div"
Sheets.Add.Name = "vol"

'Programme qui délimite la recherche par l'intégration d'une valeur en bas de colonne
Sheets(1).Select
Range("J65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "zzz"

'Programme qui recopie les lignes dans les onglets correspondants
Dim Var As Range
With Sheets(1)
For Each Var In .Range("J2:J" & .Range("J65536").End(xlUp).Row)
Var.Value = Trim(Var.Value)
Next Var
Set Var = Sheets(1).Range("J2")
Range("J2").Select
Do While Var.Value <> "zzz"
If ActiveCell.Value = "AUT" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("aut").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "CAC" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("cac").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "DIV" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("div").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "FEU" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("feu").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "INF" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("inf").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "INT" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("int").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "SON" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("son").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "VID" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("vid").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "TAL" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("tal").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
If ActiveCell.Value = "VOL" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets("vol").Select
Range("A65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets(1).Select
ActiveCell.Offset(1, 9).Select
Else
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Set Var = Var.Offset(1, 0)
Loop
End With

'Programme qui suprime le valeur en bas de colonne
Sheets(1).Select
Range("j65536").Select
Selection.End(xlUp).Select
ActiveCell.FormulaR1C1 = ""

Range("A1").Select
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Copy
Sheets(Array("vol", "div", "inf", "son", "tal", "int", "vid", "feu", "cac", "aut")).Select
Range("A1").Select
ActiveSheet.Paste
End Sub

 

[Bebere]

Re : creer des onglet a partir de ligne

bonjour Fredplongeur
une proposition
à bientôt

 

[CG2000]

Re : creer des onglet a partir de ligne

Bonsoir Bebere, fredplongeur, le Fil, le Forum,

La propo faite est parfaite, mais svp Bebere est-il possible de pratiquer le même résultat avec deux feuilles de base à dipacher en onglet. Merci par avance de vôtre aide.

C2000

 

[Bebere]

Re : creer des onglet a partir de ligne

bonjour Cg
changement effectué
à bientôt

 

[CG2000]

Re : creer des onglet a partir de ligne

Bonsoir à Tous,

Merci bien Bébere pour tes réponses. Elles me sont parfaites.
Merci pour tout.

C2000