FREDPLONGEUR
XLDnaute Junior
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
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
Pièces jointes
Dernière édition: