Bonjour,
Aussi brillant que je peux l'être, j'ai récupéré un bout de code pour procéder à un copy/paste des valeurs d'une feuille vers d'autres feuilles en fonction des valeurs disponibles dans le filtre.
Ma feuille SOURCE contient des centaines de lignes avec à la première colonne le nom de la direction (ex: Nord, Sud, Est, Ouest)
Le code me permet de créer une feuille par direction avec les données respectives pour cette direction. Je me retrouve donc avec 4 feuilles supplémentaires dans mon fichier.
Tout fonctionne bien sauf que, la macro à le même effet que le service militaire pour Elvis Presley, il passe de 3Mo à l'origine et se retrouve faire 80Mo après traitement par la macro
Si quelqu'un peut me pointer la source du problème que j'imagine est une plage trop importante. Merci
En sachant que la plage à copier dans la feuille source va de la colonne A à AH et pour un maximum 20000 lignes
** J'ajouterai un fichier un peu plus tard, il faut que je supprime pas mal de données et d'éléments d'identification avant de le faire *****
Voici le code que j'utilise:
Public Sub FilterThenCopy()
Dim ws, newWS, currentWS As Worksheet
targetCol = 1 'definition de la colonne sur laquelle appliquer l'Autofilter
Dim objDict As Variant
Set objDict = CreateObject("Scripting.Dictionary")
Set currentWS = ActiveSheet
'Add unique value in targetCol to the dictionary
Application.DisplayAlerts = False
For r = 2 To Cells(Rows.Count, targetCol).End(xlUp).Row
If Not objDict.exists(Cells(r, targetCol).Value) Then
objDict.Add Cells(r, targetCol).Value, Cells(r, targetCol).Value
End If
Next r
If currentWS.AutoFilterMode = True Then
currentWS.UsedRange.AutoFilter
End If
currentWS.UsedRange.AutoFilter
For Each k In objDict.Keys
currentWS.UsedRange.AutoFilter field:=1, Criteria1:=objDict.Item(k)
'Supprimer worksheet si worksheet avec le nom de item(k) existe déjà
For Each ws In ActiveWorkbook.Worksheets
If wsExists(objDict.Item(k)) Then
Sheets(objDict.Item(k)).Delete
End If
Next ws
'Créer une nouvelle page portant le nom de l'item item(k)
Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
newWS.Name = objDict.Item(k)
'Copier le contenu filtré vers la nouvelle feuille
currentWS.Cells.Copy
newWS.Range("A1").Select
Sheets(objDict.Item(k)).Paste
Next k
currentWS.Activate
currentWS.AutoFilterMode = False
Application.DisplayAlerts = True
End Sub