Correction et complément de ma macro

Version imprimable

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:

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

Salut.

Je te conseillerais d'utiliser les filtres automatiques qui éviteront les boucles et permettront de transférer en une fois les lignes visibles.

création d'un dictionnaire des agences pour obtenir une liste sans doublons ;
filtre automatique en itérant sur les entrées du dico ;
création d'une page pour l'agence ;
copie des données des lignes visibles dans la nouvelle feuille créée.

Voici un code exemple qui illustre cela, à adapter à ton cas

Code:

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
Sub TransfertAgences()
  Dim MonDico As New Scripting.Dictionary ' La référence Microsoft Scripting Runtime doit être cochée
  Dim Ligne As Long
  Dim Cellule As Range
  Dim Compteur As Long
  Dim shCible As Worksheet
  Dim LigneCible As Long
 
  ' Détermination de la dernière ligne de la plage
  ' La feuille contenant les données à extraire est nommée shSource dans l'éditeur VBA. A adapter
  Ligne = shSource.Range("a" & shSource.Rows.Count).End(xlUp).Row
 
  ' Remplissage du dico
  For Each Cellule In shSource.Range("O2:O" & Ligne)
    If Not MonDico.Exists(Cellule.Value) Then MonDico.Add Cellule.Value, Cellule.Value
  Next Cellule
 
  ' Filtrage des données agence par agence, création de la feuille et transfert
  ' La plage doit être adaptée. J'ai considéré qu'elle allait de A à O
  For Compteur = 0 To MonDico.Count - 1
    ' Filtrage
    shSource.Range("a1:o" & Ligne).AutoFilter field:=15, Criteria1:=MonDico.Items(Compteur)
    Set shCible = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    With shCible
      .Name = MonDico.Items(Compteur)
      ' Copie des données
      shSource.Range("a1:o" & Ligne).SpecialCells(xlCellTypeVisible).Copy Destination:=.Range("a1")
      LigneCible = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
      ' Ajout de la formule de somme
      .Range("m" & LigneCible).Formula = "=sum(m2:m" & LigneCible - 1 & ")"
 
      ' Mise en forme et définition de zone d'impression
      .Range("m:m").NumberFormat = "#,##0.00" ' A adapter à ton souhait
      .PageSetup.PrintArea = "a1:O" & LigneCible
    End With
  Next Compteur
End Sub

12/09/2011, 08h40
luffy94340

remerciement

merci encore pour la rapidité, je me lance:ccool: