Macro trop longue, et message d'erreur, à l'aide! SVP

fleurdasie

fleurdasie

XLDnaute Nouveau
Bonsoir à tous!

Je voudrais savoir si quelqu'un parmis vous serez prêt à m'aider à relire ma macro que j'ai créée et me dire s'il est possible de raccourcir certaine partie...
Je l'a trouve d'une trop longue et de deux, plus je la manipule, et plus j'ai des messages d'erreurs! alors qu'elle marchait parfaitement bien hier!

Voici le code :

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

Dim Msg, Style, Title, Response As String
Msg = "You are about to refresh the call log. Do you want to continue?"
' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Warning" ' Define title.
' context.
' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then Exit Sub

Application.DisplayAlerts = False


Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("I8").Select
ActiveCell.FormulaR1C1 = "Current Outstanding Amount"
With ActiveCell.Characters(Start:=1, Length:=28).Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("H8").Select
ActiveCell.FormulaR1C1 = "Previous Outstanding Amount"
With ActiveCell.Characters(Start:=1, Length:=27).Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With

Sheets("Data").Select
Sheets("Data").Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data").Columns("C:J").Select
Selection.Delete Shift:=xlToLeft

Sheets("Call Log").Select
Range("I9").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(C[-4],'Data'!C[-8]:C[-6],3,0),""PAID"")"
Range("I9:I" & Range("H65536").End(xlUp).Row).FillDown
Columns("I:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Columns("G:G").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

Dim i As Integer, derniereligne As Integer
derniereligne = Range("H65536").End(xlUp).Row
For i = derniereligne To 1 Step -1
If Cells(i, 8).Value = "PAID" Then
Rows(i).Delete
End If
Next


Sheets("Data").Select
Sheets("Data").Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Data").Range("E2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(C[-4],'Call Log'!C,1,0),""New"")"
Range("E2:E" & Range("D65536").End(xlUp).Row).FillDown
Sheets("Data").Columns("E:E").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
AutoFilterMode = False
Range("A1:E1").AutoFilter
Range("A1:E1").AutoFilter Field:=5, Criteria1:="New"

ActiveSheet.Range("a1", ActiveSheet.Range("D65536").End(xlUp)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy


Sheets("Call Log").Select
Sheets("Call Log").[E65536].End(xlUp)(2).PasteSpecial xlValues

Dim i2 As Integer, derniereligne2 As Integer
derniereligne2 = Range("E65536").End(xlUp).Row
For i2 = derniereligne2 To 1 Step -1
If Cells(i2, 5).Value = "ClientName" Or Cells(i2, 5).Value = "Total Invoices value" Then
Rows(i2).Delete

End If
Next


AutoFilterMode = False
ActiveWorkbook.Worksheets("Call Log").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Add Key:= _
Range("H8:H65536"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Clear


End With

MsgBox "Finished'"

Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub


A mon dernier tri par ordre décroissant, j'ai l'erreur 91 qui apparaît :(

Merci beaucoup pour votre aide!!!
 
Trier par date Trier par votes
Grand Chaman Excel

Grand Chaman Excel

XLDnaute Impliqué
Re : Macro trop longue, et message d'erreur, à l'aide! SVP

Bonsoir,

Quelques commentaires :
1. est-ce que tu peux joindre ton fichier (sans données confidentielles) car c'est plus facile de tester ainsi ?
2. tu peux simplifier en partie ta macro en supprimant tous les .Select
exemple : au lieu de Sheets("Data").Range("E2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(C[-4],'Call Log'!C,1,0),""New"")"

changer pour :
Sheets("Data").Range("E2").FormulaR1C1 = "=IFERROR(VLOOKUP(C[-4],'Call Log'!C,1,0),""New"")"

3. et aussi en supprimant tous les .Subscript = False (et autres similaires).

4. si possible utilise les balises "CODE" dans ton message la prochaine fois pour insérer ta macro, ça rendra ton message plus clair.

A+
 
Vote positif 0 Vote négatif
fleurdasie

fleurdasie

XLDnaute Nouveau
Re : Macro trop longue, et message d'erreur, à l'aide! SVP

Merci Grand Chaman!

Je ne trouvais pas la balise code... mais là c'est bon! :)

J'ai rapidement modifié le code en suivant tes conseils, ça à l'air de marcher, sauf que je tombe toujours avec le même message d'erreur 91 sur le dernier tri par ordre décroissant :(

Je posterai le fichier pour test plus tard, car faut que je cache tout avant...

Peux-tu me dire si ce code paraît plus clair après l'avoir raccourci en suivant tes conseils?

merci!
Application.ScreenUpdating = False

Dim Msg, Style, Title, Response As String
Msg = "Do you want to continue?"
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Warning" ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then Exit Sub

Application.DisplayAlerts = False

Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("I8").Select
ActiveCell.FormulaR1C1 = "Current Outstanding Amount"
With ActiveCell.Characters(Start:=1, Length:=28).Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 11
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("H8").Select
ActiveCell.FormulaR1C1 = "Previous Outstanding Amount"
With ActiveCell.Characters(Start:=1, Length:=27).Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 11
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With


Sheets("Data").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("C:J").Select
Selection.Delete Shift:=xlToLeft

Sheets("Call Log").Range("I9").FormulaR1C1 = _
"=IFERROR(VLOOKUP(C[-4],'Data'!C[-8]:C[-6],3,0),""PAID"")"
Range("I9:I" & Range("H65536").End(xlUp).Row).FillDown
Columns("I:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Columns("G:G").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

Dim i As Integer, derniereligne As Integer
derniereligne = Range("H65536").End(xlUp).Row
For i = derniereligne To 1 Step -1
If Cells(i, 8).Value = "PAID" Then
Rows(i).Delete
End If
Next

Sheets("Data").Select
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Data").Range("E2").FormulaR1C1 = _
"=IFERROR(VLOOKUP(C[-4],'Call Log'!C,1,0),""New"")"
Range("E2:E" & Range("D65536").End(xlUp).Row).FillDown
Columns("E:E").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
AutoFilterMode = False
Range("A1:E1").AutoFilter
Range("A1:E1").AutoFilter Field:=5, Criteria1:="New"

ActiveSheet.Range("a1", ActiveSheet.Range("D65536").End(xlUp)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy


Sheets("Call Log").Select
Sheets("Call Log").[E65536].End(xlUp)(2).PasteSpecial xlValues

Dim i2 As Integer, derniereligne2 As Integer
derniereligne2 = Range("E65536").End(xlUp).Row
For i2 = derniereligne2 To 1 Step -1
If Cells(i2, 5).Value = "ClientName" Or Cells(i2, 5).Value = "Total Invoices value" Then
Rows(i2).Delete

End If
Next

AutoFilterMode = False
ActiveWorkbook.Worksheets("Call Log").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Add Key:= _
Range("H8:H65536"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Clear


End With


MsgBox "Finished!'"

Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub
Cliquez pour agrandir...

Juste pour info, il y a déjà un filtre sur la ligne 8 (des titres) avant de lancer la macro.

Merci!
 
Vote positif 0 Vote négatif
Grand Chaman Excel

Grand Chaman Excel

XLDnaute Impliqué
Re : Macro trop longue, et message d'erreur, à l'aide! SVP

Bonjour,

Ton problème semble provenir du filtre... À la fin, au lieu de :

Code: 
    ActiveWorkbook.Worksheets("Call Log").AutoFilterMode = False
    ActiveWorkbook.Worksheets("Call Log").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Add Key:= _
    Range("H8"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
    With ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Clear
    End With

Essaie ceci :

Code: 
    Range("A8:H8").AutoFilter       'définir sur quelle ligne est le filtre
    ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Add Key:=Range("H8")
    
    With ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        ActiveWorkbook.Worksheets("Call Log").AutoFilter.Sort.SortFields.Clear
    End With

(sans fichier, difficile de tester)

A+
 
Vote positif 0 Vote négatif
fleurdasie

fleurdasie

XLDnaute Nouveau
Re : Macro trop longue, et message d'erreur, à l'aide! SVP

Re,

Merci d'avoir pris le temps de regarder.
La, je suis plus que perdue... j'ai essayé ton code, qui ne pas filtré par ordre décroissant mais croissant... j'ai essayé un autre code, mais depuis, j'ai plein d'autres messages d'erreur type 1004 et j'ai dû rajouter plein de : sheet("XX").Select

Voici le fichier avec la macro pour test.

Mon but est de pouvoir rafraîchir la feuille "Call log" avec les données de "Data".
La macro doit mettre à jour les nouveaux montants, supprimer les entreprises ne se trouvant plus dans "Data" et rajouter de nouveaux noms à la suite du "Call log", au final, faire un tri sur les montants.

Je ne sais pas si tu as bien saisi... pour l'instant, la macro ne marche plus comme je voudrais... elle a doublé les noms au lieu de les mettre à jour...

Je sais plus quoi faire :(

Merci beaucoup pour ton aide!
 

Pièces jointes

  • TEST.xlsm
    33.3 KB · Affichages: 80
  • TEST.xlsm
    33.3 KB · Affichages: 89
  • TEST.xlsm
    33.3 KB · Affichages: 80
Vote positif 0 Vote négatif
Grand Chaman Excel

Grand Chaman Excel

XLDnaute Impliqué
Re : Macro trop longue, et message d'erreur, à l'aide! SVP

Bonsoir fleurdasie,

Ayant en main ton fichier, j'ai mieux compris ce que tu voulais faire. Je me suis permis de modifier ta macro. Au lieu d'utiliser des filtres et des copier / coller, j'utilise plutôt un méthode de balayage de plage et de recherche de valeurs.

Voici la macro qui semble bien fonctionner. Tu devras peut-être faire quelques modifications, selon le nombre de colonnes que tu as dans ton fichier.

VB: 
Sub CleanUpData()
    Dim wsCall As Worksheet, wsData As Worksheet
    Dim i As Integer
    Dim rg As Range, rgData As Range, rgTrouve As Range
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wsCall = ThisWorkbook.Sheets("Call Log")
    Set wsData = ThisWorkbook.Sheets("Data")
    
    If MsgBox("Do you want to continue?", vbYesNo + vbCritical + vbDefaultButton2, "Warning") = vbNo Then Exit Sub
    
    'on change les montants de colonnes
    Set rg = wsCall.Range("E9")
    Do Until IsEmpty(rg)
        rg.Offset(0, 2) = rg.Offset(0, 3)
        rg.Offset(0, 3) = ""
    Set rg = rg.Offset(1, 0)
    Loop
    
    'recherche des montants précédents
    Set rg = wsCall.Range("E9")
    Set rgData = wsData.Range("A2:A" & wsData.Range("A65536").End(xlUp).Row)
    Do Until IsEmpty(rg)
            Set rgTrouve = rgData.Find(rg, , , xlWhole)
            If Not rgTrouve Is Nothing Then
                rg.Offset(0, 3) = rgTrouve.Offset(0, 11)
            Else
                rg.Offset(0, 3) = "PAID"        'pas vraiment nécessaire
                Set rg = rg.Offset(-1, 0)
                rg.Offset(1, 0).EntireRow.Delete
            End If
    Set rg = rg.Offset(1, 0)
    Loop
    
    'identifier les nouveau et les copier dans Call Log
    Set rg = wsData.Range("A2")
    Set rgData = wsCall.Range("E8:E" & wsCall.Range("E65536").End(xlUp).Row)
    Do Until IsEmpty(rg)
        Set rgTrouve = rgData.Find(rg, , , xlWhole)
        If Not rgTrouve Is Nothing Then
            rg.Offset(0, 12) = ""
        Else
            rg.Offset(0, 12) = "New"    'pas nécessaire
            With wsCall.Range("E65536").End(xlUp).Offset(1, 0)  'on ajoute à la fin
                .Offset(0, 0) = rg
                .Offset(0, 1) = rg.Offset(0, 2)
                .Offset(0, 3) = rg.Offset(0, 11)
            End With
        End If
    Set rg = rg.Offset(1, 0)
    Loop
    
    'filtre sur les nouveaux montants
    wsCall.Range("A9:N" & wsCall.Range("E65536").End(xlUp).Row).Sort Range("H8"), xlDescending, , , , , , xlNo
    
    MsgBox "Finished!"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

A+
 

Pièces jointes

  • TEST_A.xlsm
    39.1 KB · Affichages: 50
Vote positif 0 Vote négatif

Discussions similaires

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
M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
103
marie3107
M
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
143
marie3107
M
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
1 K
AtTheOne
AtTheOne
M
  • Question
XL 2010 Calcul possible dans la zone de liste pour le débit et le crédit lors d'une recherche basée sur la zone de texte
Réponses
0
Affichages
418
Mody200
M
V
  • Résolu(e)
XL 2016 Exportation au format PDF à l'aide d'une macro : erreur 1004 'Document non enregistré'
Réponses
14
Affichages
518
Phil69970
Phil69970
L
  • Question
XL 2016 Macro et suppressions de lignes
Réponses
9
Affichages
605
fanfan38
fanfan38
Usine à gaz
  • Résolu(e)
XL 2021 Filtrage que je ne parviens pas à faire
Réponses
6
Affichages
361
Usine à gaz
Usine à gaz
A
  • Résolu(e)
XL 2016 Autofill Destination sur colonne adjacente
Réponses
3
Affichages
349
Aldonanou
A
P
  • Résolu(e)
Microsoft 365 Erreur d'exécution "9" :L'indice n'appartient pas à la sélection
Réponses
9
Affichages
961
pelerin65
P

Membres actuellement en ligne

21 membres et 222 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 201
Messages
2 086 171
Membres
103 151
dernier inscrit
nassim