Alléger la formule

Le 21/08/2019 à 16:30

Bonjour,

J'essai d'améliorer pour aller plus vite dans le moulinage mais je n'y arrive point.

Voici mon écriture ci-dessous, le fichier va s'alourdir à force d'ajouter les mois

J'ai développé cette macro pour toutes mes régions afin d'envoyer le fichier à chaque chef de ventes

Merci de votre aide si vous voyez des améliorations

Sub RetrocessionsRegionDOMTOM()

'Enregistre une copie en format XLMS CHANGER LE MOIS

ActiveWorkbook.SaveAs Filename:= _

"Q:\CHIFFRES FIN DE MOIS\RETRO - VVA\2019\0-REPORTS\2019 08 - VVA\2019-2020 Rétrocessions TOTAL DOM-TOM.xlsm" _

, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

'Copie colle en valeur les onglet complet suivant

Sheets(Array("OBJECTIFS", "BDD", "VBA", "PROCEDURE", "Rapport AVRIL", "Rapport MAI", "Rapport JUIN", "Rapport T1", "Rapport JUILLET", "Rapport AOUT", "Rapport SEPT", "Rapport T2", "CA FRANCE", "CA DETAILS", "VVA REGIONS", "VVA DETAILS")).Select

Sheets("CA FRANCE").Activate

Cells.Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'Supprime dans ces onglets les colonnes demandées (sans demandé confirmation)

Application.DisplayAlerts = False

Sheets(Array("Rapport AVRIL", "Rapport MAI", "Rapport JUIN", "Rapport JUILLET", "Rapport AOUT", "Rapport SEPT", "Rapport T1", "Rapport T2")).Select

Columns("L:P").Select

Selection.Delete Shift:=xlToLeft

Application.DisplayAlerts = True

'Copie colle valeur la sélection demandé pour garder le sous.total sur la ligne 1

Sheets("COMPILATION").Select

Range("A2:X5000").Select

Range(Selection, Selection.End(xlDown)).Select

Application.CutCopyMode = False

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'Supprime les onglets suivants (sans demandé confirmation)

Application.DisplayAlerts = False

Sheets(Array("OBJECTIFS", "BDD", "VBA", "PROCEDURE", "Rapport AOUT", "Rapport SEPT", "Rapport T2", "CA REGIONS", "CA DETAILS", "VVA REGIONS", "VVA DETAILS")).Select

Sheets("VBA").Activate

ActiveWindow.SelectedSheets.Delete

Application.DisplayAlerts = True

'Supprime les lignes contenant les régions nommées sur les onglets sélectionnés

Dim i As Integer

'préciser la feuille

With ThisWorkbook.Sheets("Rapport AVRIL")

'ici colonne B

For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1

If .Range("B" & i).Value = "NORD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "PARIS" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "NORD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "TOTAL GENERAL" Then

.Rows(i).Delete

End If

Next i

End With

'préciser la feuille

With ThisWorkbook.Sheets("Rapport MAI")

'ici colonne B

For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1

If .Range("B" & i).Value = "NORD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "PARIS" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "NORD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "TOTAL GENERAL" Then

.Rows(i).Delete

End If

Next i

End With

'préciser la feuille

With ThisWorkbook.Sheets("Rapport JUIN")

'ici colonne B

For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1

If .Range("B" & i).Value = "NORD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "PARIS" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "NORD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "TOTAL GENERAL" Then

.Rows(i).Delete

End If

Next i

End With

'préciser la feuille

With ThisWorkbook.Sheets("Rapport JUILLET")

'ici colonne B

For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1

If .Range("B" & i).Value = "NORD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "PARIS" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "NORD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "TOTAL GENERAL" Then

.Rows(i).Delete

End If

Next i

End With

'préciser la feuille

With ThisWorkbook.Sheets("Rapport T1")

'ici colonne B

For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1

If .Range("B" & i).Value = "NORD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "PARIS" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "NORD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "TOTAL GENERAL" Then

.Rows(i).Delete

End If

Next i

End With

'préciser la feuille

With ThisWorkbook.Sheets("COMPILATION")

'ici colonne B

For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1

If .Range("B" & i).Value = "NORD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "SUD-OUEST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "PARIS" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "NORD-EST" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "AUTRE" Then

.Rows(i).Delete

ElseIf .Range("B" & i).Value = "TOTAL GENERAL" Then

.Rows(i).Delete

End If

Next i

End With

'Actualise les TCD

Sheets("CLIENTS").Select

ActiveSheet.PivotTables("Tableau croisé dynamique30").PivotCache.Refresh

'Sauvegarde et enregistre le fichier sous EXCEL

ActiveWorkbook.SaveAs Filename:= _

"Q:\CHIFFRES FIN DE MOIS\RETRO - VVA\2019\0-REPORTS\2019 08 - VVA\2019-2020 Rétrocessions TOTAL DOM-TOM.xlsx" _

, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

'Supprime le fichier format XLMS

Kill "Q:\CHIFFRES FIN DE MOIS\RETRO - VVA\2019\0-REPORTS\2019 08 - VVA\2019-2020 Rétrocessions TOTAL DOM-TOM.xlsm"

End Sub

Le 21/08/2019 à 19:33

Bonsoir @elodseb,

Envoie ton fichier plutôt qu'un code très long sans qu'on sache aisément à quoi il se rapporte. Peut-être que tu peux te passer de code, même…

Le 22/08/2019 à 01:46

Salut elodseb, Salut le Forum,

un début

Sub RetrocessionsRegionDOMTOM()
Dim ws As Worksheet
Dim i As Integer

'Enregistre une copie en format XLMS CHANGER LE MOIS
ActiveWorkbook.SaveAs Filename:= _
"Q:\CHIFFRES FIN DE MOIS\RETRO - VVA\2019\0-REPORTS\2019 08 - VVA\2019-2020 Rétrocessions TOTAL DOM-TOM.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

'Copie colle en valeur les onglet complet suivant
Sheets(Array("OBJECTIFS", "BDD", "VBA", "PROCEDURE", "Rapport AVRIL", "Rapport MAI", "Rapport JUIN", "Rapport T1", "Rapport JUILLET", "Rapport AOUT", "Rapport SEPT", "Rapport T2", "CA FRANCE", "CA DETAILS", "VVA REGIONS", "VVA DETAILS")).Select
Sheets("CA FRANCE").Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'Supprime dans ces onglets les colonnes demandées (sans demandé confirmation)
Application.DisplayAlerts = False
Sheets(Array("Rapport AVRIL", "Rapport MAI", "Rapport JUIN", "Rapport JUILLET", "Rapport AOUT", "Rapport SEPT", "Rapport T1", "Rapport T2")).Select
Columns("L:P").Select
Selection.Delete Shift:=xlToLeft
Application.DisplayAlerts = True

'Copie colle valeur la sélection demandé pour garder le sous.total sur la ligne 1
Sheets("COMPILATION").Range("A2:X5000").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'Supprime les onglets suivants (sans demandé confirmation)
Application.DisplayAlerts = False
Sheets(Array("OBJECTIFS", "BDD", "VBA", "PROCEDURE", "Rapport AOUT", "Rapport SEPT", "Rapport T2", "CA REGIONS", "CA DETAILS", "VVA REGIONS", "VVA DETAILS")).Select
Sheets("VBA").Activate
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

'Supprime les lignes contenant les régions nommées sur les onglets sélectionnés

'préciser la feuille
For Each ws In Worksheets(Array("Rapport AVRIL", "Rapport MAI", "Rapport JUIN", "Rapport JUILLET", "Rapport T1", "COMPILATION"))
   With ws
        'ici colonne B
        For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
        If .Range("B" & i).Value = "NORD-OUEST" Then
        .Rows(i).Delete
        ElseIf .Range("B" & i).Value = "SUD-EST" Then
        .Rows(i).Delete
        ElseIf .Range("B" & i).Value = "SUD-OUEST" Then
        .Rows(i).Delete
        ElseIf .Range("B" & i).Value = "PARIS" Then
        .Rows(i).Delete
        ElseIf .Range("B" & i).Value = "NORD-EST" Then
        .Rows(i).Delete
        ElseIf .Range("B" & i).Value = "TOTAL GENERAL" Then
        .Rows(i).Delete
        End If
        Next i
        End With
    Next ws

'préciser la feuille
With ThisWorkbook.Sheets("COMPILATION")
'ici colonne B
    For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
    If .Range("B" & i).Value = "AUTRE" Then
    .Rows(i).Delete
    End If
    Next i
End With

'Actualise les TCD
Sheets("CLIENTS").Select
ActiveSheet.PivotTables("Tableau croisé dynamique30").PivotCache.Refresh

'Sauvegarde et enregistre le fichier sous EXCEL
ActiveWorkbook.SaveAs Filename:= _
"Q:\CHIFFRES FIN DE MOIS\RETRO - VVA\2019\0-REPORTS\2019 08 - VVA\2019-2020 Rétrocessions TOTAL DOM-TOM.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

'Supprime le fichier format XLMS
Kill "Q:\CHIFFRES FIN DE MOIS\RETRO - VVA\2019\0-REPORTS\2019 08 - VVA\2019-2020 Rétrocessions TOTAL DOM-TOM.xlsm"
End Sub
Le 22/08/2019 à 14:02

Merci!!!

Rechercher des sujets similaires à "alleger formule"