Aide pour optimiser un code pour copier et effectuer opérations tri

[khadd]

Bonjour,

j'aimerai votre avis pour optimiser un code pour trier des informations. En effet, je début dans le VBA et je trouve que ce que j'ai fait n'est vraiment pas optimisé.

De plus, j'ai un autre soucis qui est largement au dessus de mes compétences actuelles, sur des notions de tri.

Cela étant un peu compliqué à expliquer par des mots. J'ai créer un fichier excel pour illustrer mes demandes.

En vous remerciant d'avance.

 

[Lone-wolf]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Bonjour khadd,

voici pour la première partie de la demande. Nomme le tableau de droite "plage", sans les entêtes et le tableau de gauche "dest" sans les entêtes aussi.

Private Sub TRI_Click()
With Sheets("OSCARR")
.Range("plage").Copy Range("c8")
 .Range("dest").Sort [C8], xlAscending, Header:=xlYes
End With
End Sub

Private Sub RAZ3_Click()
'En supposant que c'est le tableau de gauche que tu veux effacer
With Sheets("OSCARR").Range("dest")  
.ClearContents
.Borders.LineStyle = xlNone
End With
End Sub

Pour comptabiliser les clients par exemple, tu ajoute la formule =NB.SI($M$8:$M$19;E28) dans les cellules de la colonne H.

En ce qui concerne la 2ème partie, c'est compliqué pour moi; étant donné que les plages de chaque tableau sont variables.



A+

 

[khadd]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Salut Lone-Wolf,

Avant tout, merci our ton aide. J'ai écrit ce code d'après ce que tu m'as indiqué :

Private Sub TRI_Click()
Dim plage As Range
Set plage = [K8:O16] 'plage à copier
If plage(1) = "" Then
MsgBox "Pas d'entrée", 48
Else
With Sheets("OSCARR")
.Range("plage").Copy Range("C8")
.Range("dest").Sort [D8], xlAscending, Header:=xlYes
End With
End If

Cela marche très bien, si le tableau "plage" est vide. Mais, si il y a des données, excel me renvoie sans cesse au débugage en me disant : "Erreur définie par l'application ou par l'objet".

Je ne comprends pas pourquoi, peux tu m'aider ?

 

[job75]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Bonjour khadd, Lone-wolf,

Private Sub REPORTER_Click()
Dim ncol%, source As Range, deb As Range, P As Range, i&
ncol = 6 'nombre de colonnes
Set source = [K7].CurrentRegion.Resize(, ncol - 1) 'plage à adapter
Set deb = [C7] '1ère cellule des titres, à adapter
Application.ScreenUpdating = False
deb(2).Resize(Rows.Count - deb.Row, ncol).Delete xlUp 'RAZ
If source.Rows.Count = 1 Then Exit Sub
'--copie le tableau et détermine Nombre---
source.Offset(1).Copy deb(2)
Set P = deb.CurrentRegion
Set P = P(2, 1).Resize(P.Rows.Count - 1, ncol)
P.Columns(ncol) = "=COUNTIF(" & source.Columns(3).Address(1, 1, xlR1C1) & ",RC[-3])"
P.Columns(ncol) = P.Columns(ncol).Value 'supprime les formules---
P.Borders.Weight = xlThin
P.Columns(3).Borders(xlEdgeRight).LineStyle = xlNone
'---supprime les noms en doublon---
P.Sort P(1, 3), xlAscending, Header:=xlNo 'tri sur Nom
For i = P.Rows.Count To 2 Step -1
  If LCase(P(i, 3)) = LCase(P(i - 1, 3)) Then P.Rows(i).Delete xlUp
Next
'---insère les lignes et crée les titres---
P.Sort P(1), xlAscending, Header:=xlNo 'tri sur Série
For i = P.Rows.Count To 2 Step -1
  If LCase(P(i, 1)) > LCase(P(i - 1, 1)) Then
    P.Rows(i).Resize(2).Insert
    P.Rows(i).ClearFormats
    deb.Resize(, ncol).Copy P(i + 1, 1)
  End If
Next
With Me.UsedRange: End With 'actualise si nécessaire la barre de défilement verticale
End Sub

Noter que la suppression et l'insertion de lignes prennent beaucoup de temps, sur un grand tableau il faudrait une solution par tableaux VBA.

PS : votre bouton "RAZ" n'avait ici aucune utilité, je l'ai supprimé.

Fichier joint.

A+

 

[Lone-wolf]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

RE,

Une modification, avec ajout de la comptabilisation

Private Sub TRI_Click()
On Error Resume Next
With Sheets("OSCARR")
.Range("plage").Copy Range("c8")
.Range("dest").Sort [C8], xlAscending, Header:=xlYes

If .Range("e28:e36") = .Range("m8:m19") Then
.Range("h28:h36") = Application.CountIf(.Range("m8:m19"), .Range("e28:e36"))
End If
End With
End Sub

EDIT: C'est quoi plage(1) ??? - moi j'ai répéter plusieures fois la macro sans erreur.

RE_EDIT: Bonjour job, désolé on c'est croisés.

Pour éviter les bordures en trop du dernier tableau, à ajouter avant With Me.UsedRange

lig = Range("c65536").End(xlUp).Row + 1
If Cells(lig, 3).Value = "" Then Range(Cells(lig, 3), Cells(lig, 8)).Borders.LineStyle = xlNone



A+

 

[job75]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Re,

Comme je l'ai dit, sur de grands tableaux (plus de 1000 lignes) il est nécesaire d'utiliser des tableaux VBA.

La macro est moins simple :

Private Sub REPORTER_Click()
Dim ncol%, source As Range, deb As Range, rest(), d As Object, i&, n&, j%, t, titre
ncol = 6 'nombre de colonnes
Set source = [K7].CurrentRegion.Resize(, ncol - 1) 'plage à adapter
Set deb = [C7] '1ère cellule des titres, à adapter
Application.ScreenUpdating = False
deb(2).Resize(Rows.Count - deb.Row, ncol).Delete xlUp 'RAZ
If source.Rows.Count = 1 Then Exit Sub
t = source 'matrice, plus rapide
ReDim rest(1 To UBound(t), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
'--tableau sans doublon et comptage---
For i = 2 To UBound(t)
  If Not d.exists(t(i, 3)) Then
    n = n + 1
    d(t(i, 3)) = n 'repérage de la ligne
    For j = 1 To ncol - 1
      rest(n, j) = t(i, j)
    Next j
  End If
  rest(d(t(i, 3)), ncol) = rest(d(t(i, 3)), ncol) + 1 'comptage Nombre
Next i
With deb(2).Resize(n, ncol)
  .Value = rest 'restitution
  .Sort .Columns(1), xlAscending, .Columns(3), , xlAscending, Header:=xlNo 'tri
  t = .Value
End With
'---insertion de lignes et titres---
titre = deb.Resize(, ncol)
ReDim rest(1 To 3 * n, 1 To ncol)
For j = 1 To ncol: rest(1, j) = t(1, j): Next '1ère ligne
n = 1
For i = 2 To UBound(t)
  If LCase(t(i, 1)) > LCase(t(i - 1, 1)) Then
    n = n + 2
    For j = 1 To ncol
      rest(n, j) = titre(1, j)
    Next j
  End If
  n = n + 1
  For j = 1 To ncol
    rest(n, j) = t(i, j)
  Next j
Next i
'---tableau final avec bordures---
With deb(2).Resize(n, ncol)
  .Value = rest 'restitution
  Intersect(.Cells, .Columns(1).SpecialCells(xlCellTypeConstants).EntireRow) _
    .Borders.Weight = xlThin
  .Columns(3).Borders(xlEdgeRight).LineStyle = xlNone
End With
'Nota : la couleur des lignes des titres est appliquée par MFC
With Me.UsedRange: End With 'actualise si nécessaire la barre de défilement verticale
End Sub

Fichier (2).

Nota : la couleur des titres est appliquée par MFC.

A+

 

[job75]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Re,

Pour info j'ai copié la plage K8:O16 sur la plage K8:O1006.

Durées d'exécution des macros sur Win 8 -Excel 2013 :

- fichier (1) => 2,9 secondes

- fichier (2) => 0,06 seconde.

A+

 

[khadd]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Merci LONE WOLF et job75,

Tout fonctionne à merveille. Même si il va falloir que je me penche que la macro pour bien la comprendre.

En tout cas merci beaucoup

 

[khadd]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Rebonjour à tous,

je reviens vers vous concernant le même sujet.
En effet, j'avais omis de préciser une chose, que la pratique du code fait par job75 m'a montré. Je vous joint un fichier pour vous expliquer ma demande.

merci

 

[job75]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Bonjour khadd, le forum,

Avec les chiffres en colonne J il faut décaler la CurrentRegion :

Set source = [K7].CurrentRegion.Offset(, 1).Resize(, ncol - 1) 'plage à adapter

A+

 

[job75]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Re,

Si un même nom peut se trouver sur plusieurs séries la solution par tableaux VBA est la plus simple :

Private Sub REPORTER_Click()
Dim ncol%, source As Range, deb As Range, rest(), d As Object, i&, x$, n&, j%, t, titre
ncol = 6 'nombre de colonnes
Set source = [K7].CurrentRegion.Offset(, 1).Resize(, ncol - 1) 'plage à adapter
Set deb = [C7] '1ère cellule des titres, à adapter
Application.ScreenUpdating = False
deb(2).Resize(Rows.Count - deb.Row, ncol).Delete xlUp 'RAZ
If source.Rows.Count = 1 Then Exit Sub
t = source 'matrice, plus rapide
ReDim rest(1 To UBound(t), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
'--tableau sans doublon et comptage---
For i = 2 To UBound(t)
  x = t(i, 1) & Chr(1) & t(i, 3) 'Série + Nom
  If Not d.exists(x) Then
    n = n + 1
    d(x) = n 'repérage de la ligne
    For j = 1 To ncol - 1
      rest(n, j) = t(i, j)
    Next j
  End If
  rest(d(x), ncol) = rest(d(x), ncol) + 1 'comptage Nombre
Next i
With deb(2).Resize(n, ncol)
  .Value = rest 'restitution
  .Sort .Columns(1), xlAscending, .Columns(3), , xlAscending, Header:=xlNo 'tri
  t = .Value
End With
'---insertion de lignes et titres---
titre = deb.Resize(, ncol)
ReDim rest(1 To 3 * n, 1 To ncol)
For j = 1 To ncol: rest(1, j) = t(1, j): Next '1ère ligne
n = 1
For i = 2 To UBound(t)
  If LCase(t(i, 1)) > LCase(t(i - 1, 1)) Then
    n = n + 2
    For j = 1 To ncol
      rest(n, j) = titre(1, j)
    Next j
  End If
  n = n + 1
  For j = 1 To ncol
    rest(n, j) = t(i, j)
  Next j
Next i
'---tableau final avec bordures---
With deb(2).Resize(n, ncol)
  .Value = rest 'restitution
  Intersect(.Cells, .Columns(1).SpecialCells(xlCellTypeConstants).EntireRow) _
    .Borders.Weight = xlThin
  .Columns(3).Borders(xlEdgeRight).LineStyle = xlNone
End With
'Nota : la couleur des lignes des titres est appliquée par MFC
With Me.UsedRange: End With 'actualise si nécessaire la barre de défilement verticale
End Sub

Fichier (3).

Nota : cette solution étant très rapide, pourquoi ne pas utiliser une macro Worksheet_Change ?

Le tableau sera recréé chaque fois que le tableau source sera modifié, plus besoin de bouton...

[Edit] Voir le fichier (3 bis).

A+

 

[khadd]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Merci beaucoup pour ta réactivité et ta compétence

ça marche impec !



NB : mais dis moi pour le MFC, si je veux changer les colonnes C:H par F:K, comment faire ?

 

[job75]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Bonjour khadd,

NB : mais dis moi pour le MFC, si je veux changer les colonnes C:H par F:K, comment faire ?

Il faut vraiment apprendre à gérer les MFC, c'est indispensable sur Excel

- Mise en forme conditionnelle => Gérer les règles ou Nouvelle règle

- Formule =$F1="Série"

- S'applique à => $F:$K

A+

 

[khadd]

Re : Aide pour optimiser un code pour copier et effectuer opérations tri

Merci,
oui c'est vrai il faudrait que je m'y mette. Quand je vois tout ce que l'on peut faire avec excel ça donne envie.

Tu n'aurais pas des conseils de lecture pour se former (livres analogiques) pour être bien calé (avec un niveau VBA bas).

En tout cas merci