Cherche Solution pratique et simple (modification sur macro)

[Haytoch]

Bonsoir,

SVP

J'ai un fichier BDD "Partagé" et trop grand contiens des +2000 lignes en mini dans chacune de ces feuilles (+10 et chaque MAJ du fichier avec l'ajoute des nouvelle feuilles) (avec même format) , j'ai effectue des recherche et j'ai adapter la macro pour qu'elle marche bien , j'ai bien atteindre mon objectif mais ceci et très lente .

Code de la macro de megration et création de la BDD personnel.

Sub MergeSheets()
    Dim diswb As Worksheet, infwb As Workbook, swb As Worksheet
    Dim N As Long
    Dim file
Set shAct = Worksheets("BDD")
file= Application.GetOpenFilename("Excel (*.xlsx), *.xlsx", , "File Selection", , False)
  If file= False Then Exit Sub
Application.ScreenUpdating = False
        shAct.UsedRange.Offset(1).Clear
With Workbooks.Open(file)
    wb = .Name
    TWay = Environ("temp")
    WbDest = "cg-temp.xlxs"
    TDest = TWay & WbDest
    Application.DisplayAlerts = False
    Workbooks(wb).SaveCopyAs TDest
    .Close savechanges:=False
 End With

With Workbooks.Open(TDest)
  '      .ExclusiveAccess
For N = 1 To .Worksheets.Count
            With Worksheets(N)
                .UsedRange.Offset(1).Copy
            End With
                        With shAct.Range("A65536").End(xlUp).Offset(1, 0)
                            .PasteSpecial Paste:=xlValues
                            '.PasteSpecial Paste:=xlFormats
                        End With
Next N
            .Close savechanges:=False
        End With
With shAct
    .Range("H:I,K:N").Delete
    .Range("H1").Value = "Index"
    .Range("A1").Copy
    .Range("H1").PasteSpecial Paste:=xlPasteFormats
    .Range("A1:B1,G1:H1").Copy
    .Range("J1").PasteSpecial Paste:=xlPasteValues
    .Range("J1").PasteSpecial Paste:=xlPasteFormats
    .Range("J1:M1").Copy
    .Range("J14").PasteSpecial Paste:=xlPasteValues
    .Range("J14").PasteSpecial Paste:=xlPasteFormats
End With
End Sub

aprés l’exécution de la macro du megration je fait une execution d'une autre macro (filtre avancé) que j'ai déjà eu dans le post suivant :

https://www.excel-downloads.com/threads/filtre-copier-les-donnees-aide-sur-macro.206309/

Sub Get_index_Morpho()
    Dim tr As Integer
    Dim i As Long, J As Long, DerL As Long
    Dim Bwsh As Worksheet
    Dim solsh As Worksheet
    Dim CriteriaPl As Range, DesPl As Range

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set Bwsh = Worksheets("Analyse")
    Set solsh = Worksheets("Conf-BDD")

    For J = 2 To Bwsh.Range("A" & Rows.Count).End(xlUp).Row
        'Set solsh = Worksheets("SOL" & Bwsh.Cells(J, 8))

        With solsh
            DerL = .Range("A" & .Rows.Count).End(xlUp).Row
            .Range("A1:E" & DerL).Name = "Base" 'critères
            .Range("J2") = Bwsh.Range("A" & J)    'produit
            .Range("K2") = Bwsh.Range("D" & J)    ' traitement
        End With
        
    Set CriteriaPl = solsh.Range("J1:L2")
    Set DesPl = solsh.Range("J9:L9")
        
        solsh.Range("J10") = ""
        solsh.Range("K10") = ""
        solsh.Range("K10") = ""
        Range("Base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CriteriaPl, CopyToRange:=DesPl
        If solsh.Range("J10") <> "" Then
            Bwsh.Range("E" & J) = solsh.Range("L10")
            Bwsh.Range("F" & J) = solsh.Range("K10")
        Else
            tr = solsh.Range("K2")
            For i = 1 To tr
                solsh.Range("K2") = tr - i
                Range("Base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CriteriaPl, CopyToRange:=DesPl
                If Range("BDD!J10") <> "" Then
                    Bwsh.Range("E" & J) = solsh.Range("L10")
                    Bwsh.Range("F" & J) = solsh.Range("K10")
                    Exit For
                End If
            Next i
            If solsh.Range("J10") = "" Then
                With Bwsh
                    .Range("E" & J) = "None!"
                    .Range("F" & J) = "None !"
                    .Range("G" & J) = "Solution jamais livrée"
                End With
             End If
         End If

    Next J
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Merci de m'aider a minimisé le temps et la vitesse d'assemblage (car par fois ceci me bloque l'excel )

au bien si vous avez une solution plus pratique .


merci pour votre support

slt haytoch

 

[Zon]

Re : Cherche Solution pratique et simple (modification sur macro)

Bonjour,

sur mergesheets,

pourquoi ouvrir le fichier , en faire une copie le fermer pour le rouvrir la copie?

donc je travaillerai directement sur la copie

With Workbooks.Open(file)
    wb = .Name
    TWay = Environ("temp")
    WbDest = "cg-temp.xlxs"
    TDest = TWay & WbDest
    Application.DisplayAlerts = False
    Workbooks(wb).SaveCopyAs TDest
    
With Workbooks(TDest)
  '      .ExclusiveAccess
For N = 1 To .Worksheets.Count
            With Worksheets(N)
                .UsedRange.Offset(1).Copy
            End With
                        With shAct.Range("A65536").End(xlUp).Offset(1, 0)
                            .PasteSpecial Paste:=xlValues
                            '.PasteSpecial Paste:=xlFormats
                        End With
Next N

mais c'est pas cela qui ralentit le plus le code...


dans l'autre procédure faire une boucle pour écrire des valeurs dans Excel c'est là que le code est ralenti , il faut passer par les variables tableaux
, et puis définir à chaque itération de J un nom(base ici) dans excel c'est ce qui explique certainement par moment le blocage d'excel


donc si je comprends bien cette partie de code

For J = 2 To Bwsh.Range("A" & Rows.Count).End(xlUp).Row
        'Set solsh = Worksheets("SOL" & Bwsh.Cells(J, 8))

        With solsh
            DerL = .Range("A" & .Rows.Count).End(xlUp).Row
            .Range("A1:E" & DerL).Name = "Base" 'critères
            .Range("J2") = Bwsh.Range("A" & J)    'produit
            .Range("K2") = Bwsh.Range("D" & J)    ' traitement
        End With

on peut la remplacer par qqch comme suit on écrira que 2 fois dans la feuille excel sachant que T et V seront des variants
dim T, dim V

with bswh
t=.range("A2:A" & .Rows.Count).End(xlUp).Row).value
V=.range("D2:D" & .Rows.Count).End(xlUp).Row).value
end with
        With solsh
            .Range("J2").resize(ubound(t),1) = t 'produit
            .Range("K2").resize(ubound(V),1)=v   ' traitement
            DerL = .Range("A" & .Rows.Count).End(xlUp).Row
            .Range("A1:E" & DerL).Name = "Base" 'critères
        
End With

[/CODE]

ensuite pour tes filtres , y a de la boucle qui copie des données mais difficle sans fichier exemple de tes données

A+++

PS Si c'est pas assez clair n'hésites pas.

 

[Haytoch]

Re : Cherche Solution pratique et simple (modification sur macro)

Tout d'abord merci pour ta réponse Zon

pour:

Bonjour,

sur mergesheets,

pourquoi ouvrir le fichier , en faire une copie le fermer pour le rouvrir la copie?

donc je travaillerai directement sur la copie

mais c'est pas cela qui ralentit le plus le code...

Oui effectivement je fait une copier pour le fichier vers le dossier temporaire afin de enlevé le partage au fichier et la protection du fichier ( avec un mot de passe).

dans l'autre procédure faire une boucle pour écrire des valeurs dans Excel c'est là que le code est ralenti , il faut passer par les variables tableaux
, et puis définir à chaque itération de J un nom(base ici) dans excel c'est ce qui explique certainement par moment le blocage d'excel

on peut la remplacer par qqch comme suit on écrira que 2 fois dans la feuille excel sachant que T et V seront des variants
dim T, dim V

ensuite pour tes filtres , y a de la boucle qui copie des données mais difficle sans fichier exemple de tes données

j’aimerai bien faire avec cette méthode mais je suis débutant VBA , j'ai essaie de minimisé mais taches au travaille.

je te mis au PJ des exemple de fichiers :

1 -indices_tr_Produits.xlmx ==> Fichier de la Macro.
2-BaseDeDonnées_Exemple==> Exemple de la BDD .


merci pour votre aide


Slt
Haytoch

 

[Zon]

Re : Cherche Solution pratique et simple (modification sur macro)

re,

m'ai trompat ,

avec l'exemple je comprends ce que tu veux, il faut éviter ces filtres et se les faire soi même en VBA par des array à la volée.

Bon là il est tard , je te poste le code demain ...

A+++

 

[Haytoch]

Re : Cherche Solution pratique et simple (modification sur macro)

Okey

Merci bcp

 

[Zon]

Re : Cherche Solution pratique et simple (modification sur macro)

Salut,

voici une proposition d'amélioration de Get_index_morpho , à tester

si c'est trop long (moi testé sur 7000 lignes en à livrer et 3000 en BDD ça me semble raisonnable 8 secondes),

=> il faudra à trier ta bdd sur nom plutot que par indices quitte à retrier sur indices.
autre piste tes produits sont toujours en DRT000 alors il faudra scinder BDD (via code VBA) afin d'éviter une boucle sur 10000 éléments et gagner en temps d'éxécution ...demandes en MP pour m'envoyer le cas échéant ta BDD grandeur nature ...

A+++

à coller dans ton module1

Sub FiltreZon()
  Dim I As Long ', J As Long, DerL As Long
  Dim Bwsh As Worksheet, Solsh As Worksheet
  Dim T, V
  Application.ScreenUpdating = False
    Set Bwsh = Worksheets("A livré")
    Set Solsh = Worksheets("BDD")
  
  With Bwsh
    T = Range(.[A2], .Range("G" & .[A65536].End(xlUp).Row)).Value
  End With
  With Solsh
    V = Range(.[A2], .Range("E" & .[A65536].End(xlUp).Row)).Value
  End With
  
  For I = LBound(T) To UBound(T)
    Temp = RechIndice(V, T(I, 1), T(I, 4))
    T(I, 5) = IIf(Temp(0) = "", "None!", Temp(0))
    T(I, 6) = IIf(Temp(1) = "", "None!", Temp(1))
    T(I, 7) = IIf(Temp(2) = "", "Solution jamais livrée", Temp(2))
  Next I
  
  Bwsh.[A2].Resize(UBound(T), UBound(T, 2)) = T
    
End Sub

Function RechIndice(T, ByVal Crit1$, ByVal Crit2&, Optional C1% = 1, Optional C2% = 4, _
                      Optional Res2% = 4, Optional Res1% = 5)
  'T est 1 tableau à 2 dimension, Crit1 est le nom du produit, crit2 est 1 nombre de traitement
  'C1 et C2 sont les colonnes sur lesquelles on veut effectuer le critère,
  'RES1 et res2 sont les numéros de colonne de résultat
Dim I&, J&, K&, Temp(0 To 2), Boule As Boolean

  For I = LBound(T) To UBound(T)
    If T(I, C1) = Crit1 Then
      If T(I, C2) = Crit2 Then
        Temp(0) = T(I, Res1): Temp(1) = T(I, Res2): Temp(2) = " "
        Exit For
      Else
        For J = 1 To Crit2
          For K = LBound(T) To UBound(T)
            If T(K, C1) = Crit1 Then
              If T(K, C2) = Crit2 - J Then
                Temp(0) = T(K, Res1): Temp(1) = T(K, Res2): Temp(2) = " "
                Boule = True
                Exit For
              End If
            End If
          Next K
          If Boule Then Exit For
        Next J
      End If
    End If
  Next I
 RechIndice = Temp
End Function