1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
| Sub Classement_par_Onglets()
j = 2
l = 2
Lig = 2
Dim code As String
Application.DisplayAlerts = False
S_LIG = InputBox(" PRECISEZ la COLONNE qui va servir de base pour créer les ONGLETS :")
Range("A2").Select
For f = l To 200000
Range(S_LIG & j).Select
code = "_" & ActiveCell.FormulaR1C1 '********* Code = cellule
code = Left(code, 30)
If code = "_" Then Exit For '********* si cellule vide alors Fin
If Left("_" & ActiveCell.Value, 29) = code Then '******** si la cellule active de Feuil1 = code
Range("A" & j & ":" & "B" & j & ":" & "X" & j).Select
Selection.Copy
On Error Resume Next
Sheets(code).Select '********** Passage à onglet = CODE
If Err.Number = 9 Then '********** Contrôle si onglet = code absent alors création
Sheets.Add.Name = code
Sheets("SELECTION").Select
Cells(Lig, 1).Value = code
Lig = Lig + 1
Sheets("Feuil1").Select
Range("A1:AK1").Select
Selection.Copy
Sheets(code).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=False
Sheets("Feuil1").Select
Range("A" & j & ":" & "B" & j & ":" & "X" & j).Select
Selection.Copy
Sheets(code).Select
Range(A2).Select
Err.Clear
Err.Number = 0
End If
Range("A2").Select
line1:
If ActiveCell.Value = "" Then
ActiveSheet.Paste '******* Si Cellule vide alors on colle
Selection.Offset(1, 0).Select
Else
Selection.Offset(1, 0).Select
GoTo line1
End If
Else
Selection.Offset(1, 0).Select
End If
j = j + 1
Sheets("feuil1").Select
Next f
Sheets("feuil1").Select
ActiveSheet.Shapes("Button 1").Select
Selection.Cut
ActiveWindow.SelectedSheets.Delete
Sheets("Selection").Select
ActiveWorkbook.SaveAs Filename:= _
"C:\DATALOC\ONGLET.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Range("A1:B5344").Select
Range("B2").Activate
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
code = ActiveCell.FormulaR1C1
Range("C2").Select
ActiveCell.Value = code '********* Code = cellule
End Sub |
Partager