Code VBA trop lourd

Bonjour,

Un peu novice en VBA j'ai fait ce code mais ca allourdi énormément mon fichier et je voulais savoir si vous auriez une solution pour qu'il prenne moins de place ? Peut être j'ai pensé: faire exécuter le code que sur les lignes qui sont remplies mais je ne sais pas comment faire.

Le code: j'extrait une base de donnée (nom de l'entreprise avec les produits qu'elle fait et leurs caractéristique) et j'aimerai qu'en fonction du nom de l'entreprise ca se copie colle dans le feuille de l'entreprise. J'ai testé une solution avec Power query mais pareil le fichier était beaucoup trop lourd voilà pourquoi je me suis rabattue sur du vba.

Merci beaucoup pour votre aide !!

Sub Macro4()
' Macro4 Macro

' Decache Colonne
    Sheets("Extract").Select
    Cells.EntireColumn.Hidden = False

'Entreprise A
    Sheets("Extract").Select
    ActiveSheet.Range("$A$1:$Q$77").AutoFilter Field:=5, Criteria1:="Entreprise A"
    Columns("A:Q").Select
    Selection.Copy
    Sheets("A").Select
    Range("A1").Select
    ActiveSheet.Paste

'Entreprise B
    Sheets("Extract").Select
    ActiveSheet.Range("$A$1:$Q$77").AutoFilter Field:=5, Criteria1:="Entreprise B"
    Columns("A:Q").Select
    Selection.Copy
    Sheets("B").Select
    Range("A1").Select
    ActiveSheet.Paste

'Entreprise C
    Sheets("Extract").Select
    ActiveSheet.Range("$A$1:$Q$77").AutoFilter Field:=5, Criteria1:="Entreprise C"
    Columns("A:Q").Select
    Selection.Copy
    Sheets("C").Select
    Range("A1").Select
    ActiveSheet.Paste

'Entreprise D
    Sheets("Extract").Select
    ActiveSheet.Range("$A$1:$Q$77").AutoFilter Field:=5, Criteria1:="Entreprise D"
    Columns("A:Q").Select
    Selection.Copy
    Sheets("D").Select
    Range("A1").Select
    ActiveSheet.Paste

'Entreprise E
    Sheets("Extract").Select
    ActiveSheet.Range("$A$1:$Q$77").AutoFilter Field:=5, Criteria1:="Entreprise E"
    Columns("A:Q").Select
    Selection.Copy
    Sheets("E").Select
    Range("A1").Select
    ActiveSheet.Paste

'Entreprise F
    Sheets("Extract").Select
    ActiveSheet.Range("$A$1:$Q$77").AutoFilter Field:=5, Criteria1:="Entreprise F"
    Columns("A:Q").Select
    Selection.Copy
    Sheets("F").Select
    Range("A1").Select
    ActiveSheet.Paste

'nofilter()
On Error Resume Next
    Sheets("Extract").ShowAllData

Sheets("TCD").Select 'pour revenir automatiquement sur feuille TCD

End Sub

Commence par enlever tout les Select, il ne servent à rien ou presque fait plutot un code du style :

Sheets("XXX").range("A1").value

ou

Sheets("XXX").cells(x,y).copy

et enlève les activesheets aussi du coup

Après tu peux aussi faire une boucle avec un truc comme :

For i = Asc(A) to Asc(C) 'mets le nombre d'entreprise que tu veux 

Sheets("Extract").Select
    ActiveSheet.Range("$A$1:$Q$77").AutoFilter Field:=5, Criteria1:="Entreprise " & chr(i + 64)
    Columns("A:Q").Copy
    Sheets(chr(i+64)).Range("A1").Pastespecial

Next i 

J'ai chopé ces infos sur le forum donc pas sur que ca fonctionne vraiment à tester

Bonjour,

Je ne connais pas votre version Excel, Mais je ne vois pas comment votre fichier pourrait etre trop lourd pour query ? Personnellement je gère plus de 1M5 lignes de données avec PQ sans problème.

Un exemple de votre fichier permettrai de vous montrez les possibilités

EDIT : Je viens de voir que c'est moi même qui avait répondu a votre ancienne demande. qu'est ce qui posait problème ? pcq utiliser des copiés collé va drastiquement augmenté la taille de votre fichier

J'ai fait ce que tu m'as dit ca me donne une erreure.

Je voudrais bien te mettre le fichier excel mais il est tellement lourd qu'il ne charge pas.

Sub Macro4()
' Macro4 Macro

' Decache Colonne
Sheets("Extract").Select
Cells.EntireColumn.Hidden = False

'Entreprise A
Sheets("Extract").Select
ActiveSheet.Range("$A$1:$j$77").AutoFilter Field:=4, Criteria1:="A"
Columns("A:j").Select
Selection.Copy
Sheets("Entreprise A").Range("A1").Value
ActiveSheet.Paste

Je vous le redis mais des copiés collés vont augmenter la taille de votre fichier de façon importante.

En quoi ma solution power Query de votre ancien post ne fonctionnais pas ?

Power Query n'alourdit pas un fichier. Votre fichier doit surement etre très lourd de base

S'il est trop c'est peut être que dans ton code tu fais intervenir des colonnes et lignes très loin (genre colonne ZZ ou ligne 10 000). Regarde si t'es barre de défilement ne sont pas toute petite je pense que c'est ca j'avais eu le même problème.

Si tu as des Backup de tes fichiers et que le poids de ton fichier augmente d'un coup c'est surement ca.

Est-ce que tu peux me dire ou sont les erreurs ?

Merci beaucoup Arthur AMY pour tes solutions !!

Ca beug au niveau de la ligne <Sheets("Entreprise A").Range("A1").Value>

Je vais essayer de faire la boucle que tu m'as donné merci beaucoup !!

Je pense que le code fait intervenir des lignes backups car ce sont les colonnes entières qui sont sélectionnées mais c'est ca que je ne sais pas faire comment faire appliquer le code uniquement aux lignes qui sont remplis ? Sachant que d'une extraction à une autre il n' y aura pas le même nombre de ligne

Valentin85 alors déjà merci beaucoup pour ta solution PQ qui m'avait bien bien aidé et surtout fait découvrir PQ. Si ca fonctionne parfaitement c'était gééééénial !! Quand j'ai essayé d'envoyer le fichier par mail il me disait que c'était trop lourd. Alors j'ai peut être mal fait qqch. Mais c'est clair que la solution PQ est mille fois meilleur et mille fois plus simple et tellement mieux !

PQ n'allourdi pas !? Alors je dois avoir des lignes en backup alors. Je vais re regarder et je vous dis ;)

Mon fichier fait 269Mo

Votre fichier est censé seulement contenir des données ? pcq 270 Mo pour juste des données c'est impossible. Vous devez avoir des éléments parasites

Bonjour à tous !

pms, voici une base de code pour copier tes données mais sans fichier...on ne peut tester

Bonne journée !

Merci Nordik_Nation pour ton exemple. Je l'ai testé il ne fonctionne pas je l'ai surement mal adapté.

Ca copie et colle uniquement la première ligne de titre dans toutes les feuilles mais pas le reste je n'ai pas trouvé pourquoi ;)

Salut Arthur Amy, j'ai testé le code que tu as chopé sur le forum mais la dernière ligne n'arrive pas à s'exécuter

Bonjour,

    Columns("A:Q").Select
    Selection.Copy

si tu copie-colles des colonnes entières, c'est normal que ça pose un pb.

Commence par nettoyer toutes tes feuilles.
Tu fais Ctrl+Fin sur chacune et tu notes la dernière ligne et dernière colonne utilisées.
Tu sélectionnes toutes les lignes entièrement vides (sélectionner sur les n° de ligne) qui dépassent de tes données et Supprimer par le clic-droit.
Idem sur les colonnes si besoin.
Enregistrer le fichier et regarde sa taille.

Ensuite il ne faut copier que les lignes visibles après application des filtres :
Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase").Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
s'il est possible qu'un filtre ramène 0 ligne il faut tester avant pour ne pas copier dans ce cas...
eric

Bonjour à tous !

pms je ne comprends pas pourquoi est-ce que ça copier seulement la première

J'ai fait un exemple fichier ça sera à toi de l'adapter ici ça fonctionne très bien voici le fichier

Bonne journée !

Désolée Nordik_Nation ton fichier fonctionne super bien c'est bien moi qui faisait l'erreur. Merci beaucoup pour ton aide !!
Petite question commente faire pour que ca prenne la dernière ligne automatiquement sans à avoir à réécrire le code car en fonction des mois j'aurais 48 puis 50 puis 75 puis 78 lignes ...

Encore merci pour ton aide précieuse ! ;)

Bonjour à tous !

pms, je ne vois pas l'utilité de prendre jusqu'à la dernière ligne ??? Ça copie toute la colonne entière mais je te l'ai rajouté quand même si c'est ta demande

N'oublie pas de mettre en résolu si ton problème est réglé...merci !

Bonne journée !

c'est que chaque mois il y aura des données supplémentaire qui vont s'ajouter et si j'ai bien compris le code précédent il ne va que jusqu'à la ligne 25. et donc une fois la ligne 25 dépassé les autres données ne vont pas se traiter. Voilà pourquoi ;)

Ca marche en tout cas merci

de rien pms...