Traitement d'une macro long et créant un sheets trop long
Bonjour, je suis débutant en VBA et j'aurais besoin d'aide, je m'excuse d'avance si les lignes que j'ai écrites vous donnes envie de m'égorger
Enfin, je vous explique mon problème : j'avais créé mes maccros pour automatiser le traitement de nos fichiers de base clients, et elles tournaient, le seul problème étant que elle nous ramenait à un sheets qui renvoyait le nombre maximum de ligne ( + d'un million ) et le traitement était donc rallongé et le document très compliqué à utiliser ( seulement 3/4000 lignes utiles mais un document d'1 M de ligne )
j'ai donc tenté plusieurs choses pour corriger ça : j'ai tenté des xLup mais j'ai l'impression que c'est ça qui crée les documents méga longs. J'ai imposé 5000 lignes max mais j'aimerais pouvoir le faire à chaque fois avec la dernière ligne active.
En plus, j'en ai profité pour corriger pas mal de petits détails de débutants mais maintenant mon algo tourne en continue pour rien, et je n'ai aucune idée du comment.
Je sais que je demande quelques chose qui prend du temps, mais je vous serez infiniment reconnaissant si vous pouvez m'aider à corriger ça et à me former
Merci beaucoup,
Alban
Sub Automatisation()
Sheets("Newsheet").Select
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").FormulaR1C1 = "vérification"
Range("B2").FormulaR1C1 = _
"=IF(AND(OR(LEFT(RC[-1],FIND(""@"",RC[-1])-1)=LOWER(RC[2]),LEFT(RC[-1],FIND(""@"",RC[-1])-1)=LOWER(RC[4]),AND(LEFT(RC[-1],1)=LEFT(RC[4],1),FIND(""@"",RC[-1])-1=OR(LEN(RC[2])+2,LEN(RC[2])+1))),RC[1]=""Server using catch all""),1,0)"
Range("B2").Select
Selection.AutoFill Destination:=Range("B2:B5000")
Range("B2:B5000").Select
Sheets("NewSheet").Select
Range("C2").FormulaR1C1 = "=VLOOKUP(RC[-2],email!C[-1]:C,2,FALSE)"
Range("C2").AutoFill Destination:=Range("C2:C5000")
Range("E2").FormulaR1C1 = "=VLOOKUP(RC[-1],prenoms!C[-4]:C[-3],2,FALSE)"
Range("E2").AutoFill Destination:=Range("E2:E5000")
Columns("K:K").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("K1").FormulaR1C1 = "NB. SI"
Range("K2").FormulaR1C1 = "=COUNTIF(C[1],RC[1])"
Range("K2").AutoFill Destination:=Range("K2:K5000")
Range("Y2").FormulaR1C1 = _
"=IFNA(VLOOKUP(RC[1],email!C[-23]:C[-22],2,FALSE),""null"")"
Range("Y2").AutoFill Destination:=Range("Y2:Y5000")
Range("Y2:Y5000").Select
End Sub
Sub remplacement_mail()
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=3, Criteria1:= _
"=Not valid", Operator:=xlOr, Criteria2:="=#N/A"
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=25, Criteria1:= _
"=Email is valid", Operator:=xlOr, Criteria2:="=Server using catch all"
Dim i As Integer
i = 1
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Rows(i).Hidden = False Then
Cells(i, 1).Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[25]"
End If
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=3, Criteria1:= _
"=Email is valid", Operator:=xlOr, Criteria2:="=Server using catch all"
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=25
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=2, Criteria1:="=1", _
Operator:=xlOr, Criteria2:="=#N/A"
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=25, Criteria1:= _
"=Email is valid", Operator:=xlOr, Criteria2:="=Server using catch all"
Next
Dim k As Integer
k = 1
For k = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Rows(k).Hidden = False Then
Cells(k, 1).Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[25]"
End If
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=2
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=25
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=3, Criteria1:= _
"Server using catch all"
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=25, Criteria1:= _
"Email is valid"
Dim n As Integer
n = 1
For n = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Rows(n).Hidden = False Then
If Cells(n, 11) >= 6 Then
Cells(n, 1).Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[25]"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End If
End If
Next
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=3
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=25
End Sub
End Sub
Sub Trie()
ActiveSheet.Range("$A$1:$AM$10000").AutoFilter Field:=3
Columns("E:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("E2").FormulaR1C1 = "=IF(RC[1]=""m"",""m"",IF(RC[1]=""m,f"",""m"",""f""))"
Range("E2").AutoFill Destination:=Range("E2:E10000")
Range("E2:E5000").Select
Columns("E:E").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("F:F").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=5, Criteria1:="=f", _
Operator:=xlOr, Criteria2:="=m"
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=3, Criteria1:= _
"=Email is valid", Operator:=xlOr, Criteria2:="=Server using catch all"
ActiveSheet.Range("$A$1:$AM$5000").AutoFilter Field:=2, Criteria1:="0"
Columns("A:AR").Select
Selection.Copy
Dim F1 As Worksheet
Set F1 = Sheets.Add(After:=Sheets(Sheets.Count))
F1. name = "trie"
ActiveSheet.Paste
End Sub
Sub AfterFinal()
Call Automatisation
Call remplacement_mail
Call Trie
End Sub