Bonjour à tous,
Dans mon fichier en PJ, j'aimerais d'abord si c'est possible réduire ma macro.
Le but de ma macro est qu'a chaque changement d'agence (colonne O), un onglet est crée et les données y sont collées.
Le nombre d'onglet varie selon le nombre d'agence.
Mon 2ème problème :
Je voudrais compléter ma macro de façon à ce que le format de colonne dans chaque onglet soit le même car certaines sont tronquées, mais aussi faire un total dans chaque onglet de la colonne (M) montant et définir une zone d'impression dans chaque onglet sachant que le nombre de ligne est variables.

voici ma macro

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
82
83
84
85
86
87
88
89
90
91
92
93
Sub princeipal()
'macro qui copie et colle dans un autre onglet
Range(Range("A1"), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)).Select
 
    Selection.copy
    Sheets("Feuil1").Select
 
ActiveSheet.Paste
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
 
Cells.Select
 
'macro wokbook permet de creer un onglet à chaque changement d'agence et d'y coller les infos
 
Dim Sh As Worksheet
Dim LastLig As Long, NewLig As Long, i As Long
Dim NomFeuil As String
 
Application.ScreenUpdating = False
With Sheets("Feuil1")
   LastLig = .Cells(.Rows.Count, "O").End(xlUp).Row
    For i = 2 To LastLig
 
        NomFeuil = CStr(.Range("O" & i).Value)
        If NomFeuil <> "" Then
            On Error Resume Next
            Set Sh = Sheets(NomFeuil)
            On Error GoTo 0
            If Sh Is Nothing Then
                Set Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                Sh.Name = NomFeuil
 
                .Rows(1).copy Sh.Range("A1")  'celllule ou commence le coller des données
 
            End If
 
            'end If termine la boucle si plus d'agence
 
            NewLig = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row + 1  'le +1 insert une ligne entre chaque agence
            .Rows(i).copy Sh.Range("A" & NewLig)
            Set Sh = Nothing
        End If
    Next i
 
   Sheets.Add After:=Sheets(Sheets.Count)
 
   ReDim MonArray(Worksheets.Count - 4) '-4 car tu ne prends pas les 4 premières feuilles
'ni la dernière et l'array commence à l'indice 0
For i = 3 To Worksheets.Count - 1  'Parcours des feuilles
    MonArray(i - 3) = Sheets(i).Name
Next i
Sheets(MonArray).Select    'sélection de l'ensemble
 
 
'macro classemnt feuil
 
Dim X As Variant
'Dim I As Variant
For Each X In ActiveWorkbook.Sheets
For i = 2 To ActiveWorkbook.Sheets.Count
If Sheets(i - 1).Name > Sheets(i).Name Then
Sheets(i - 1).Move After:=Sheets(i)
End If
Next
Next
 
End With
 
Sheets("Havas").Select
    Sheets("Havas").Move Before:=Sheets(1)
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Feuil1").Select
    Sheets("Feuil1").Move Before:=Sheets(2)
 
 ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Havas").Select
    Rows("1:1").Select
    Selection.copy
 
ReDim MonArray(Worksheets.Count - 4) '-4 car tu ne prends pas les 4 premières feuilles
'ni la dernière et l'array commence à l'indice 0
For i = 3 To Worksheets.Count - 1  'Parcours des feuilles
   MonArray(i - 3) = Sheets(i).Name
Next i
Sheets(MonArray).Select    'sélection de l'ensemble
 
Rows("1:1").Select
    Selection.Insert Shift:=xlDown
 
 
End Sub

Merci par avance