XL 2013 Simplification de code

S

sr94

XLDnaute Occasionnel
Bonjour,

A l'aide de ce forum et de codes trouvés sur internet j'ai créé une macro pour
- importer des classeurs dans une feuille "RECAP" en les consolidant (ils ont tous la même structure et je reçois 1 fichier par fournisseur)
- supprimer les lignes de ma feuille "Production_Schedule" qui correspondent aux lignes des fournisseurs dans la feuille "RECAP"
- copier les lignes consolidées à la suite de la feuille "'Production_Schedule"

Voici le résultat de cette macro, mais est ce possible de l'améliorer notamment pour que l'exécution soit plus rapide ?

Code: 
Sub Compilation_1()

Public ProdSchedule As Worksheet, shRecap As Worksheet
Public FichierR$, CheminR$

Set ProdSchedule = ThisWorkbook.Worksheets("Production_Schedule")
Set shRecap = ThisWorkbook.Worksheets("RECAP")

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

With ProdSchedule
    If .FilterMode Then
    .ShowAllData
    End If
    Columns("A:AM").EntireColumn.Hidden = False
End With
Stop


'Consolider les production schedules
shRecap.Visible = True

Do While FichierR <> ""

    Set F = Workbooks.Open(CheminR & FichierR)
    derligne = F.Sheets(1).Range("A65000").End(xlUp).Row


    With F.Worksheets(1)
        If .FilterMode Then .ShowAllData
        Sheets("Feuil1").Columns("A:AM").EntireColumn.Hidden = False
    End With
  
    F.Sheets(1).Range("A2:AI" & derligne).Copy shRecap.Range("A65000").End(xlUp).Offset(1, 0)
    F.Close SaveChanges:=False
  
    FichierR = Dir

Loop

'Supprimer les lignes des production schedules importés

Dim cel As Range, derlig&, derL&, i&

    Application.ScreenUpdating = False
    derlig = Sheets("Production_Schedule").Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Production_Schedule")
        derL = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = derL To 2 Step -1
            Set cel = shRecap.Range("c2:c" & derlig).Find(.Range("c" & i).Value, lookat:=xlWhole)
            If Not cel Is Nothing Then
                .Rows(i).Delete
                Set cel = Nothing
            End If
        Next i
    End With

shRecap.Activate

'Ne pas afficher les cellules vides
ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:="<>"


'Selectionner toutes les cellules pleines et indiquer la date
shRecap.Activate
    Range("AI2").FormulaR1C1 = "=""Importé le ""&TEXT(now(),""jj-mmm-aa hh:mm"" )"
   [AI2:AI2].AutoFill Range("AI2:AI" & Cells(Rows.Count, 1).End(xlUp).Row)


derL_MAJ = shRecap.Cells(Rows.Count, 1).End(xlUp).Row
derL_TB = 1 + Sheets("Production_Schedule").Cells(Rows.Count, 1).End(xlUp).Row

shRecap.Range("a2:AI" & derL_MAJ).Copy

Sheets("Production_Schedule").Activate

Range("A" & derL_TB).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

'vider RECAP
    With Sheets("RECAP")
        .Rows("2:65536").EntireRow.Delete
        .Visible = False
    End With

'*****************

'Retirer les filtres et lancer les macros pour la mise en forme
Sheets("Production_Schedule").Activate


'supprimer les fichiers reçus
Kill CheminR & "*.*"


MsgBox "Les Production Schedules ont été importés !"

End Sub


Merci beaucoup
 
Trier par date Trier par votes
Lone-wolf

Lone-wolf

XLDnaute Barbatruc
Bonjour sr94 :)

change déjà : derligne = F.Sheets(1).Range("A65000").End(xlUp).Row par
Range("A" & Rows.Count).End(xlUp).Row; ça m'étonnerais beaucoup que le tableau soit remplis jusqu'à la cellule 65000. o_O

Et ici

vider RECAP
With Sheets("RECAP")
.Rows("2:65536").EntireRow.Delete
.Visible = False
End With

Sheets("RECAP").Range("a2:am" & derligne).ClearContents
 
Vote positif 0 Vote négatif
S

sr94

XLDnaute Occasionnel
Merci beaucoup, en effet j'ai dans les 10000 lignes.

Voici donc le code modifié :

Code: 
Sub Compilation_1()

Dim ProdSchedule As Worksheet, shRecap As Worksheet
Dim FichierR$, CheminR$
Dim Wb As Workbook

Set ProdSchedule = ThisWorkbook.Worksheets("Production_Schedule")
Set shRecap = ThisWorkbook.Worksheets("RECAP")
Set Wb = ThisWorkbook
CheminR = Wb.Path & "\Production Schedules reçus\"
FichierR = Dir(CheminR & "*.xls*")

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

With ProdSchedule
    If .FilterMode Then
    .ShowAllData
    End If
    Columns("A:AM").EntireColumn.Hidden = False
End With


'Consolider les production schedules
shRecap.Visible = True

Do While FichierR <> ""

    Set F = Workbooks.Open(CheminR & FichierR)
    derligne = F.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row


    With F.Worksheets(1)
        If .FilterMode Then .ShowAllData
        Sheets("Feuil1").Columns("A:AM").EntireColumn.Hidden = False
    End With
  
    F.Sheets(1).Range("A2:AI" & derligne).Copy shRecap.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    F.Close SaveChanges:=False
  
    FichierR = Dir

Loop

'Supprimer les lignes des production schedules importés

Dim cel As Range, derlig&, derL&, i&

    Application.ScreenUpdating = False
    derlig = Sheets("Production_Schedule").Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Production_Schedule")
        derL = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = derL To 2 Step -1
            Set cel = shRecap.Range("c2:c" & derlig).Find(.Range("c" & i).Value, lookat:=xlWhole)
            If Not cel Is Nothing Then
                .Rows(i).Delete
                Set cel = Nothing
            End If
        Next i
    End With

shRecap.Activate

'Ne pas afficher les cellules vides
ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:="<>"


'Selectionner toutes les cellules pleines et indiquer la date
shRecap.Activate
    Range("AI2").FormulaR1C1 = "=""Importé le ""&TEXT(now(),""jj-mmm-aa hh:mm"" )"
   [AI2:AI2].AutoFill Range("AI2:AI" & Cells(Rows.Count, 1).End(xlUp).Row)


derL_MAJ = shRecap.Cells(Rows.Count, 1).End(xlUp).Row
derL_TB = 1 + Sheets("Production_Schedule").Cells(Rows.Count, 1).End(xlUp).Row

shRecap.Range("a2:AI" & derL_MAJ).Copy

Sheets("Production_Schedule").Activate

Range("A" & derL_TB).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

'vider RECAP
With Sheets("RECAP")
.Range("a2:am" & derligne).ClearContents
.Visible = False
End With

'*****************

Sheets("Production_Schedule").Activate

'supprimer les fichiers reçus
Kill CheminR & "*.*"


MsgBox "Les Production Schedules ont été importés !"

End Sub
 
Vote positif 0 Vote négatif
S

sr94

XLDnaute Occasionnel
J'ai une interrogation sur ce code :

Code: 
'Supprimer les lignes des production schedules importés

Dim cel As Range, derlig&, derL&, i&

    Application.ScreenUpdating = False
    derlig = Sheets("Production_Schedule").Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Production_Schedule")
        derL = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = derL To 2 Step -1
            Set cel = shRecap.Range("c2:c" & derlig).Find(.Range("c" & i).Value, lookat:=xlWhole)
            If Not cel Is Nothing Then
                .Rows(i).Delete
                Set cel = Nothing
            End If
        Next i
    End With

Si je comprends bien la macro va chercher dans le colonne C de "RECAP" les noms des fournisseurs sur toutes les lignes ".
Dans la pratique il va y avoir maximum 15 fournisseurs - 5000 lignes sur RECAP / 30 fournisseurs - 10000 lignes sur Production Schedule. N'est-il pas possible de mémoriser la liste des fournisseurs de RECAP et ensuite de scanner l'onglet principal pour supprimer les lignes en fonction de cette liste ? dans la pratique c'est cette partie du code qui prend du temps.

Merci encore.
 
Dernière édition:
Vote positif 0 Vote négatif
S

sr94

XLDnaute Occasionnel
J'ai trouvé le début du code pour lister les fournisseurs existants dans "RECAP"

Code: 
Sub ListeSansDoublons()
  Set mondico = CreateObject("Scripting.Dictionary")
  a = Sheets("RECAP").Range("C2:C" & [C65000].End(xlUp).Row)   ' tableau a(n,1)
  For i = LBound(a) To UBound(a)
    mondico(a(i, 1)) = ""
  Next i
  Sheets("RECAP").[AN1].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
End Sub

Quel serait le code pour dire de supprimer dans la feuille "Production_Schedule" les lignes dont le nom en colonne C existe dans la liste de la colonne AN de la feuille RECAP ?

Je joins un fichier test (sans le code de ce message)

Merci beaucoup
 

Pièces jointes

  • Test V1.zip
    103.7 KB · Affichages: 25
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

S
  • Résolu(e)
XL 2016 Besoin d'aide pour un code d'extraction
Réponses
14
Affichages
267
Phil69970
Phil69970
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
232
Zonmé
Z
A
  • Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
101
Phil69970
Phil69970
R
  • Question
XL 2016 excel 2016 VBA
Réponses
2
Affichages
151
rebatte
R
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
908
thivame
T
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
345
M@xu3L
M
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
207
Compte Supprimé 979
C
E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
143
eric72
E
lynyrd
  • Résolu(e)
XL 2016 Supprimer 1 sur 13
Réponses
6
Affichages
129
lynyrd
lynyrd
A
  • Résolu(e)
XL 2016 Autofill Destination sur colonne adjacente
Réponses
3
Affichages
348
Aldonanou
A

Membres actuellement en ligne

19 membres et 134 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 161
Messages
2 085 855
Membres
103 005
dernier inscrit
gilles.hery