Réduction code VBA
Bonjour
à vous,
Pourriez vous s'il vous plait m'aider à réduire ce code. Je dois aller jusqu'à la ligne 275... et je n'arrive à faire ce que je veux qu'avec cette méthode.
et sincèrement ça ferai un code ultra sans "simplification"
Merci d’avance
Sub Filtre_par_Critères()
'
' Filtre_par_Critères Macro
'
ActiveSheet.Unprotect ("mps")
Sheets("BASE INVENTAIRE").Range("Inventaire[[#All],[Centrale]:[Etat]]"). _
AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"RENSEIGNEMENTS!Criteria"), CopyToRange:=Range("RENSEIGNEMENTS!Extract"), _
Unique:=False
If Not IsEmpty("AH204") Then
Worksheets("RENSEIGNEMENTS").Range("C204").Value = Worksheets("RENSEIGNEMENTS").Range("AH204").Value
Else
Worksheets("RENSEIGNEMENTS").Range("C204").Value = ("")
End If
If Not IsEmpty("AI204") Then
Worksheets("RENSEIGNEMENTS").Range("H204").Value = Worksheets("RENSEIGNEMENTS").Range("AI204").Value
Else
Worksheets("RENSEIGNEMENTS").Range("H204").Value = ("")
End If
If Not IsEmpty("AJ204") Then
Worksheets("RENSEIGNEMENTS").Range("O204").Value = Worksheets("RENSEIGNEMENTS").Range("AJ204").Value
Else
Worksheets("RENSEIGNEMENTS").Range("O204").Value = ("")
End If
If Not IsEmpty("AK204") Then
Worksheets("RENSEIGNEMENTS").Range("S204").Value = Worksheets("RENSEIGNEMENTS").Range("AK204").Value
Else
Worksheets("RENSEIGNEMENTS").Range("S204").Value = ("")
End If
If Not IsEmpty("AH205") Then
Worksheets("RENSEIGNEMENTS").Range("C205").Value = Worksheets("RENSEIGNEMENTS").Range("AH205").Value
Else
Worksheets("RENSEIGNEMENTS").Range("C205").Value = ("")
End If
If Not IsEmpty("AI205") Then
Worksheets("RENSEIGNEMENTS").Range("H205").Value = Worksheets("RENSEIGNEMENTS").Range("AI205").Value
Else
Worksheets("RENSEIGNEMENTS").Range("H205").Value = ("")
End If
If Not IsEmpty("AJ205") Then
Worksheets("RENSEIGNEMENTS").Range("O205").Value = Worksheets("RENSEIGNEMENTS").Range("AJ205").Value
Else
Worksheets("RENSEIGNEMENTS").Range("O205").Value = ("")
End If
If Not IsEmpty("AK205") Then
Worksheets("RENSEIGNEMENTS").Range("S205").Value = Worksheets("RENSEIGNEMENTS").Range("AK205").Value
Else
Worksheets("RENSEIGNEMENTS").Range("S205").Value = ("")
End If
If Not IsEmpty("AH206") Then
Worksheets("RENSEIGNEMENTS").Range("C206").Value = Worksheets("RENSEIGNEMENTS").Range("AH206").Value
Else
Worksheets("RENSEIGNEMENTS").Range("C206").Value = ("")
End If
If Not IsEmpty("AI206") Then
Worksheets("RENSEIGNEMENTS").Range("H206").Value = Worksheets("RENSEIGNEMENTS").Range("AI206").Value
Else
Worksheets("RENSEIGNEMENTS").Range("H206").Value = ("")
End If
If Not IsEmpty("AJ206") Then
Worksheets("RENSEIGNEMENTS").Range("O206").Value = Worksheets("RENSEIGNEMENTS").Range("AJ206").Value
Else
Worksheets("RENSEIGNEMENTS").Range("O206").Value = ("")
End If
If Not IsEmpty("AK206") Then
Worksheets("RENSEIGNEMENTS").Range("S206").Value = Worksheets("RENSEIGNEMENTS").Range("AK206").Value
Else
Worksheets("RENSEIGNEMENTS").Range("S206").Value = ("")
End If
If Not IsEmpty("AH207") Then
Worksheets("RENSEIGNEMENTS").Range("C207").Value = Worksheets("RENSEIGNEMENTS").Range("AH207").Value
Else
Worksheets("RENSEIGNEMENTS").Range("C207").Value = ("")
End If
If Not IsEmpty("AI207") Then
Worksheets("RENSEIGNEMENTS").Range("H207").Value = Worksheets("RENSEIGNEMENTS").Range("AI207").Value
Else
Worksheets("RENSEIGNEMENTS").Range("H207").Value = ("")
End If
If Not IsEmpty("AJ207") Then
Worksheets("RENSEIGNEMENTS").Range("O207").Value = Worksheets("RENSEIGNEMENTS").Range("AJ207").Value
Else
Worksheets("RENSEIGNEMENTS").Range("O207").Value = ("")
End If
If Not IsEmpty("AK207") Then
Worksheets("RENSEIGNEMENTS").Range("S207").Value = Worksheets("RENSEIGNEMENTS").Range("AK207").Value
Else
Worksheets("RENSEIGNEMENTS").Range("S207").Value = ("")
End If
If Not IsEmpty("AH208") Then
Worksheets("RENSEIGNEMENTS").Range("C208").Value = Worksheets("RENSEIGNEMENTS").Range("AH208").Value
Else
Worksheets("RENSEIGNEMENTS").Range("C208").Value = ("")
End If
If Not IsEmpty("AI208") Then
Worksheets("RENSEIGNEMENTS").Range("H208").Value = Worksheets("RENSEIGNEMENTS").Range("AI208").Value
Else
Worksheets("RENSEIGNEMENTS").Range("H208").Value = ("")
End If
If Not IsEmpty("AJ208") Then
Worksheets("RENSEIGNEMENTS").Range("O208").Value = Worksheets("RENSEIGNEMENTS").Range("AJ208").Value
Else
Worksheets("RENSEIGNEMENTS").Range("O208").Value = ("")
End If
If Not IsEmpty("AK208") Then
Worksheets("RENSEIGNEMENTS").Range("S208").Value = Worksheets("RENSEIGNEMENTS").Range("AK208").Value
Else
Worksheets("RENSEIGNEMENTS").Range("S208").Value = ("")
End If
If Not IsEmpty("AH209") Then
Worksheets("RENSEIGNEMENTS").Range("C209").Value = Worksheets("RENSEIGNEMENTS").Range("AH209").Value
Else
Worksheets("RENSEIGNEMENTS").Range("C209").Value = ("")
End If
If Not IsEmpty("AI209") Then
Worksheets("RENSEIGNEMENTS").Range("H209").Value = Worksheets("RENSEIGNEMENTS").Range("AI209").Value
Else
Worksheets("RENSEIGNEMENTS").Range("H209").Value = ("")
End If
If Not IsEmpty("AJ209") Then
Worksheets("RENSEIGNEMENTS").Range("O209").Value = Worksheets("RENSEIGNEMENTS").Range("AJ209").Value
Else
Worksheets("RENSEIGNEMENTS").Range("O209").Value = ("")
End If
If Not IsEmpty("AK209") Then
Worksheets("RENSEIGNEMENTS").Range("S209").Value = Worksheets("RENSEIGNEMENTS").Range("AK209").Value
Else
Worksheets("RENSEIGNEMENTS").Range("S209").Value = ("")
End If
End SubBonjour à tous,
Voici un essai si j'ai compris , code édité :
Sub Filtre_par_Critères()
with sheets("RENSEIGNEMENTS")
set plage = .range("AH204:AK275")
temp = plage
for i = lbound(temp) to ubound(temp)
for k = lbound(temp, 2) to ubound(temp, 2)
if temp(i, k) = "" then
col = choose(k, 3, 8, 15, 19)
lig = plage.row + i - 1
temp(i, k) = .cells(lig, col).value
else
temp(i, k) = ""
end if
next k
next i
plage = temp
end with
End SubCdlt,
Merci pour vos réponse.
Je ne peux pas joindre le fichier, c'est pour cela que j'ai copié seulement le code.
Le principe est simple: en formule ça donne ça :
Formule en C204 =SI(ESTVIDE(AH204);"";AH204)
Formule en C205 =SI(ESTVIDE(AH205);"";AH205)
Jusqu'à la ligne 275.
Sauf qu'en formule classique, cela fonctionnait un coup sur deux. EN VBA, niquel. sauf que ma "structure" de code est ultra longue.
D'où ma venue.
J'essai la proposition de de 3GB ( Merci à toi 3BG )
----------------------------------------
EN gros je dois copier (SI NON VIDE ) la plage AH204:AK275 vers C204:T275
Avec ta réponse, je viens de voir que j'ai inversé le problème !
Voici un code qui devrait mieux répondre au problème :
Sub Filtre_par_Critères()
with sheets("RENSEIGNEMENTS")
set plage = .range("AH204:AK275")
for i = 1 to plage.rows.count
for k = 1 to plage.columns.count
col = choose(k, 3, 8, 15, 19)
lig = plage.row + i - 1
.cells(lig, col).value = plage(i, k)
next k
next i
end with
End SubCdlt,
Et j'ai un peu modifier ma réponse aussi, si cela t'aide.
Merci à toi
Merci pour vos réponse.
Je ne peux pas joindre le fichier, c'est pour cela que j'ai copié seulement le code.
Le principe est simple: en formule ça donne ça :
Formule en C204 =SI(ESTVIDE(AH204);"";AH204)
Formule en C205 =SI(ESTVIDE(AH205);"";AH205)
Jusqu'à la ligne 275.
Sauf qu'en formule classique, cela fonctionnait un coup sur deux. EN VBA, niquel. sauf que ma "structure" de code est ultra longue.
D'où ma venue.
J'essai la proposition de de 3GB ( Merci à toi 3BG )
----------------------------------------
EN gros je dois copier (SI NON VIDE ) la plage AH204:AK275 vers C204:T275
C'est bon, c'est modifié.
Par contre, ici, ce sont les colonnes 3, 8, 15 et 19 (donc resp. C, H, O, S) qui prennent les valeurs de AH, AI, AJ, AK.
S'il faut que ce soit la colonne T et non la S, il faudra remplacer 19 par 20 à la ligne choose.
J'ai de nouveau édité le code car je crois que le test sur la cellule vide n'est pas utile ici.
Ok j'ai compris, remplacer les lettres par les numéro de colone.
Cela change quelque chose à ton code si les cellules de destinations sont fusionnées ?
AH vers (CEllules fusionnées): C,D,E,F et G
AI vers (CEllules fusionnées): H,I,J,KJ,L,M,N
AJ vers (CEllules fusionnées): O,P,Q,R
AK vers (CEllules fusionnées): S, et T
Normalement, non, surtout si à chaque fois, C, H etc sont les premières cellules du groupe mais il vaut mieux éviter de fusionner des cellules !
Je sais que les fusions créés des soucis...
je vais essayer sans fusion
Ok j'ai compris, remplacer les lettres par les numéro de colonne.
Cela change quelque chose à ton code si les cellules de destinations sont fusionnées ?
AH vers (CEllules fusionnées): C,D,E,F et G
AI vers (CEllules fusionnées): H,I,J,KJ,L,M,N
AJ vers (CEllules fusionnées): O,P,Q,R
AK vers (CEllules fusionnées): S, et T
J'ai défusionné et laissé les colone correspondantes aux chiffres de ton code.
Mais quand j'execute la macro, cette ligne pose soucis: .Cells(lig, col).Value = ""
J'ai remplacé un égal par différent dans
If plage(i, k) <> "" Thença à l'air mieux
With Sheets("RENSEIGNEMENTS")
Set plage = .Range("AH204:AK275")
For i = 1 To plage.Rows.Count
For k = 1 To plage.Columns.Count
If plage(i, k) <> "" Then
col = Choose(k, 3, 8, 15, 19)
lig = plage.Row + i - 1
.Cells(lig, col).Value = plage(i, k)
Else
.Cells(lig, col).Value = ""
End If
Next k
Next i
End With
End SubEn fait, c'est un reliquat du mauvais code précédent. Mais, tu devrais copier mon dernier code édité sans le if car je doute qu'il serve.
Est il possible de vider la plage de destination avant le code que tu m'as fournis ?
J'ai essayer de rajouter ça: Range("C204:T275").ClearContents
Mais ça mouline à mort
Sub Filtre_par_Critères()
'
' Filtre_par_Critères Macro
'
ActiveSheet.Unprotect ("mps")
Sheets("BASE INVENTAIRE").Range("Inventaire[[#All],[Centrale]:[Etat]]"). _
AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"RENSEIGNEMENTS!Criteria"), CopyToRange:=Range("RENSEIGNEMENTS!Extract"), _
Unique:=False
Range("C204:T275").ClearContents
With Sheets("RENSEIGNEMENTS")
Set plage = .Range("AH204:AK275")
For i = 1 To plage.Rows.Count
For k = 1 To plage.Columns.Count
If plage(i, k) <> "" Then
col = Choose(k, 3, 8, 15, 19)
lig = plage.Row + i - 1
.Cells(lig, col).Value = plage(i, k)
Else
.Cells(lig, col).Value = ""
End If
Next k
Next i
End With
End SubVoici un essai anti-moulinette
Sub Filtre_par_Critères()
'
' Filtre_par_Critères Macro
'
ActiveSheet.Unprotect ("mps")
Sheets("BASE INVENTAIRE").Range("Inventaire[[#All],[Centrale]:[Etat]]"). _
AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"RENSEIGNEMENTS!Criteria"), CopyToRange:=Range("RENSEIGNEMENTS!Extract"), _
Unique:=False
application.calculation = xlCalculationAutomatic
With Sheets("RENSEIGNEMENTS")
Set plage = .Range("AH204:AK275")
lig = plage.row
For k = 1 To plage.Columns.Count
col = Choose(k, 3, 8, 15, 19)
temp = application.transpose(plage.columns(k))
.cells(lig, col).resize(ubound(temp), 1) = application.transpose(temp)
Next k
End With
End SubCdlt,
GÉNIAL !!! Celui est mieux, il ne mouline pas !
Et j'avais des "raté" avec l'autre des cases arrivait vide, et là ça à l'air niquel
derrière question: j'ai cette forùule au dessus pour compter le nombre de ligne qui apparaissent avec le code
=NBVAL(C204:C275)
Mais je ne comprend, elle ne s'actualise pas, il que je la réécrive pour qu'elle fonctionne
Nickel ! J'aurais partir sur ça directement...
La formule ne s'actualise pas ? Et le calcul est en automatique, pas en manuel ?
Edit : Peux-tu essayer de rajouter cette ligne avant le with : application.calculation = xlCalculationAutomatic
Non la formule reste à 1, dernière fois où je l'ai réécrite.
J'ai pas la première à ma faire ça. C'est aussi pour ça que tu as modifié mon code, car je l'avais fait avec des formules, et elle ne s'actualisait pas.
Je ne comprend pas.
Qu'entends tu par, le calcul est en automatique ?
Bah il y a plusieurs options de calcul, manuel (il faut le déclencher ou sélectionner la cellule et valider), automatique ou semi-automatique.
Ca expliquerait ton souci de formule car tu aurais tout à gagner honnêtement en mettant cette simple formule :
=AH204Je comprend ce que tu dis, mais où et comment je change ça ?
Car j'ai l'impression que ça affecte d'autre formule avec RECHERCHEV, alors que ç ne le faisais pas avant