Autres Optimiser une macro

[grotsblues]

Bonjour le forum

Est il possible de condenser les codes ci-joint sachant qu'ils sont attribués à un onglet.

Merci pour vos réponses.

Sub RCS()

Dim nbligne As Long
nbligne = Range("B5").CurrentRegion.Rows.Count

'supprime frzz0
Sheets("RCS").Select

For i = nbligne To 5 Step -1
If celles(2, i).Value = "FRZZ0" Then Selection.EntireRow.Delete

End If
Next i

'remplace les cotes par rien

Range("K3").Select
derligne = Cells(Rows.Count, 3).End(xlUp).Row
Range("K3:K" & derligne).Replace What:="'", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


'mettre au format texte


Selection.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 2), TrailingMinusNumbers:=True

'remplace les cotes par rien

derligne = Cells(Rows.Count, 3).End(xlUp).Row
Range("M3:M" & derligne).Replace What:="'", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

'remplace les cotes par rien

derligne = Cells(Rows.Count, 3).End(xlUp).Row
Range("U3:U" & derligne).Replace What:="'", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Range("AG3").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-31],RC[-29])"
Selection.AutoFill Destination:=Range("AG3:AG348224")
Range("AG3:AG348224").Select


End Sub

Sub AppelAHSub()
Set TableSource = Sheets("AXE MANAGEMENT").Range("AT2:AU45000") ' champ table source
derligne = Cells(Rows.Count, 3).End(xlUp).Row
Set ClésCherchées = Sheets("RCS").Range("AG3:AG" & derligne) ' champ des clés recherchées
Set Résultat = Sheets("RCS").Range("AH3:AH" & derligne) ' champ résultat
colResult = 2
RechvAH ClésCherchées, TableSource, 2, Résultat
End Sub
Sub RechvAH(ClésCherchées, TableSource, colRésult, Résultat)
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
a = TableSource.Value ' table source
b = ClésCherchées.Value ' table des clés recherchées
For i = LBound(a) To UBound(a)
d(a(i, 1)) = a(i, colRésult)
Next i
Dim temp()
ReDim temp(LBound(b) To UBound(b), 1 To 1)
For i = LBound(b) To UBound(b)
If d(b(i, 1)) <> "" Then temp(i, 1) = d(b(i, 1)) Else temp(i, 1) = "Inconnu"
Next i
Résultat.Value = temp
End Sub

Sub AppelAISub()
Set TableSource = Sheets("REFERENTIEL CATEGORIE PO").Range("F5:H45000") ' champ table source
derligne = Cells(Rows.Count, 3).End(xlUp).Row
Set ClésCherchées = Sheets("RCS").Range("K3:K" & derligne) ' champ des clés recherchées
Set Résultat = Sheets("RCS").Range("AI3:AI" & derligne) ' champ résultat
colResult = 3
RechvAI ClésCherchées, TableSource, 3, Résultat
End Sub
Sub RechvAI(ClésCherchées, TableSource, colRésult, Résultat)
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
a = TableSource.Value ' table source
b = ClésCherchées.Value ' table des clés recherchées
For i = LBound(a) To UBound(a)
d(a(i, 1)) = a(i, colRésult)
Next i
Dim temp()
ReDim temp(LBound(b) To UBound(b), 1 To 1)
For i = LBound(b) To UBound(b)
If d(b(i, 1)) <> "" Then temp(i, 1) = d(b(i, 1)) Else temp(i, 1) = "Inconnu"
Next i
Résultat.Value = temp
End Sub

Sub AppelAKSub()
Set TableSource = Sheets("REFERENTIEL CATEGORIE PO").Range("F5:G45000") ' champ table source
derligne = Cells(Rows.Count, 3).End(xlUp).Row
Set ClésCherchées = Sheets("RCS").Range("K3:K" & derligne) ' champ des clés recherchées
Set Résultat = Sheets("RCS").Range("AJ3:AJ" & derligne) ' champ résultat
colResult = 2
RechvAK ClésCherchées, TableSource, 2, Résultat
End Sub
Sub RechvAK(ClésCherchées, TableSource, colRésult, Résultat)
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
a = TableSource.Value ' table source
b = ClésCherchées.Value ' table des clés recherchées
For i = LBound(a) To UBound(a)
d(a(i, 1)) = a(i, colRésult)
Next i
Dim temp()
ReDim temp(LBound(b) To UBound(b), 1 To 1)
For i = LBound(b) To UBound(b)
If d(b(i, 1)) <> "" Then temp(i, 1) = d(b(i, 1)) Else temp(i, 1) = "Inconnu"
Next i
Résultat.Value = temp
End Sub
Sub statutEetM()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

derligne = Range("A400000").End(xlUp).Row
For ligne = 3 To derligne


If Range("AF" & ligne).Value = "E" Or Range("AF" & ligne).Value = "M" Then
Range("AK" & ligne).Value = "EXCLUS"
Else: Range("AK" & ligne).Value = "OUI"


End If
Next ligne

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub statutCetN()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

derligne = Range("A400000").End(xlUp).Row
For ligne = 3 To derligne


If Range("T" & ligne).Value = "C" Or Range("T" & ligne).Value = "N" Then
Range("AL" & ligne).Value = "EXCLUS"
Else: Range("AL" & ligne).Value = "OUI"


End If
Next ligne

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub AL()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

derligne = Range("A400000").End(xlUp).Row
For ligne = 3 To derligne


If Range("D" & ligne).Value = "FRZ9AA" Or Range("D" & ligne).Value = "FRZ9A4" Or Range("D" & ligne).Value = "FRZ965" Or Range("D" & ligne).Value = "FRZ9A5" Or Range("D" & ligne).Value = "FRZ9AB" Then
Range("AM" & ligne).Value = "EXCLUS"
Else: Range("AM" & ligne).Value = "OUI"


End If
Next ligne

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub CATEGORIE()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

derligne = Range("A400000").End(xlUp).Row
For ligne = 3 To derligne


If Range("K" & ligne).Value = "85102" And Range("d" & ligne).Value = "FR660" Or Range("K" & ligne).Value = "84204" Or Range("K" & ligne).Value = "70152" Or Range("K" & ligne).Value = "82210" Then
Range("AN" & ligne).Value = "EXCLUS"
Else: Range("AN" & ligne).Value = "OUI"


End If
Next ligne

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub FR570()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

derligne = Range("A400000").End(xlUp).Row
For ligne = 3 To derligne


If Range("B" & ligne).Value = "FR570" And Range("D" & ligne).Value = "RCS2019" Then
Range("AO" & ligne).Value = "EXCLUS"
Else: Range("AO" & ligne).Value = "OUI"


End If
Next ligne

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub RETENUOUINON()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

derligne = Range("A400000").End(xlUp).Row
For ligne = 3 To derligne


If Range("AK" & ligne).Value = "A GARDER" And Range("AL" & ligne).Value = "A GARDER" And Range("AM" & ligne).Value = "OUI" And Range("AN" & ligne).Value = "OUI" And Range("AO" & ligne).Value = "OUI" Then
Range("AP" & ligne).Value = "OUI"
Else: Range("AP" & ligne).Value = "EXCLUS"


End If
Next ligne

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[job75]

Bonjour,

Aucune explication, vous voulez donc qu'on épluche votre code, très peu pour moi.

A+

 

[Compte Supprimé 979]

Salut job75

Code qui plus est n'est pas entre balises... le bouton </> doit être invisible pour certains

 

[grotsblues]

Bonjour,

Aucune explication, vous voulez donc qu'on épluche votre code, très peu pour moi.

A+

Bonsoir
Non je ne vous demande pas d'éplucher mon code, je demande seulement si on peut condenser ce code afin d'éviter plusieurs boutons. Cela dit le code que j'ai écris et de supprimer des lignes si des cellules contiennent un texte, de remplacer une cote par rien, de faire une recherchev…...etc
Je pensais qu'il était préférable de proposer un code plutôt que de demander au forum de faire le travail.
Bonne soirée