Discussion :

[ARK72]

Bonjour à tous,
Je me vois dans l'obligation de réaliser une macro pour réaliser la chose suivante :
- selon un critère de rupture, créer une feuille (nommé comme ce critère, ici un nom de commune)
- copier les données de cette commune dans ce nouvel onglet

J'ai adapté des choses trouvées ici et là, car le VBA, c'est loin !!!!
Les données sont dans la première feuille, le critère se situe en l'espèce dans la colonne 3.
Ma macro marche nickel, à un détail près.
Assez vite, la RAM utilisée augmente en flèche et, bien sûr, j'ai un message mémoire insuffisante et ça plante...
J'ai essayé de vider le presse papier, rien n'y fait.
Pour info le fichier fait environ 150 000 lignes sur 20 colonnes.
Il y a environ 485 valeurs différentes pour le critère (je sais ça va faire beaucoup de feuilles , mais c'est ce que dois faire).
Mais ça coince bien avant.
J'utilise une version 32 bits d'excel 2016.
Voilà 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
Sub decoup()
 
Dim lr As Long 'étendue des données
Dim ws As Worksheet
Dim vcol As Long
Dim i As Long
Dim icol As Long
Dim myarr As Variant 'paramètre de rupture
Dim title As String 'étendue titres colonnes
Dim titlerow As Long 'ligne titres colonnes
vcol = 3 'colonne du paramètre de rupture
Set ws = Sheets("données_source") 'feuille des données
 
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:T1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
 
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
MsgBox ("Fin du découpage")
End Sub

Je sèche là....
Un grand merci d'avance pour vos réponses.

[MarcelG]

Bonjour Ark, et bienvenu sur ce Forum,

A toute fin utile, tu peux consulter cette modeste contribution Alimenter des feuilles depuis une synthèse.

[ARK72]

Merci à toi, cela m'a été fort utile.

[MarcelG]

Tant mieux.
Tu peux aborder les notions qui y sont reportées à travers beaucoup de sources sur ce Forum.
Notamment celles que je mentionne au post #20 de cette discussion.

Quant à celle-ci, pense à la placer en mode "Résolue".

A bientôt.