• Initiateur de la discussion Initiateur de la discussion Marion
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

M

Marion

Guest
Bonsoir le forum.

Je reviens juste, je n'est pas encore répondu au post d'avant hier mais mais j'y vais juste aprés ça.

Baside ma fait une macro mais elle ne fonctionne plus et je ne sais pas pouquoi.

La zone BDD est bien définie
voici la macro

Dim Chang As Integer
Dim C As Integer
Dim Col As Byte
Dim Nom As String
Dim L As Integer

Sub OUI_NON()
' CHANGER LE NOM DE LA FEUILLE ICI LE METTRE ENTRE ' '
Nom = 'SAISIE QUANTITE'
' Contrôles remplissage des dates
If Worksheets(Nom).Range('AS3') = '' Then MsgBox ' Date': Exit Sub
If Worksheets(Nom).Range('AU3') = '' Then MsgBox ' Date': Exit Sub
Worksheets(Nom).Range('AQ2') = '>=' & Worksheets(Nom).Range('AS3')
Worksheets(Nom).Range('AR2') = '<=' & Worksheets(Nom).Range('AU3')
Worksheets(Nom).Range('AT2') = '>=' & Worksheets(Nom).Range('AS3')
Worksheets(Nom).Range('AU2') = '<=' & Worksheets(Nom).Range('AU3')
' Recherche sezlon critères
Application.ScreenUpdating = False

la macro s'arrête juste ne dessous pourquoi???????????

Range('BDD').AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
'AQ1:AS2'), CopyToRange:=Range('AR5:AS200'), Unique:=False
Range('BDD').AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
'AT1:AV2'), CopyToRange:=Range('AT5:AU200'), Unique:=False
ActiveWindow.SmallScroll Down:=-15

' Ordre alphabètique
Range('AR6:AS20').Select
Selection.Sort Key1:=Range('AR6'), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range('AT6:AU20').Select
Selection.Sort Key1:=Range('AT6'), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For Chang = 6 To 3000
If Sheets(Nom).Range('AS' & Chang) = 'oui' Then Sheets(Nom).Range('AS' & Chang).Value = 1
If Sheets(Nom).Range('AU' & Chang) = 'non' Then Sheets(Nom).Range('AU' & Chang).Value = 1
Next

' Elimination des doublons et addition dans les cellules à droite
L = Sheets(Nom).Range('AR20').End(xlUp).Row
Col = 44
For C = 5 To L
If Sheets(Nom).Cells(C, Col).Value = '' Then Exit For
If Sheets(Nom).Cells(C, Col) = Sheets(Nom).Cells(C + 1, Col) Then _
Sheets(Nom).Cells(C, Col + 1).Value = Sheets(Nom).Cells(C, Col + 1).Value + 1: _
Cells(C + 1, Col).Delete shift:=xlUp: Cells(C + 1, Col + 1).Delete shift:=xlUp
Next

L = Sheets(Nom).Range('AT65536').End(xlUp).Row
Col = 46
For C = 5 To L
If Sheets(Nom).Cells(C, Col).Value = '' Then Exit For
If Sheets(Nom).Cells(C, Col) = Sheets(Nom).Cells(C + 1, Col) Then _
Sheets(Nom).Cells(C, Col + 1).Value = Sheets(Nom).Cells(C, Col + 1).Value + 1: _
Cells(C + 1, Col).Delete shift:=xlUp: Cells(C + 1, Col + 1).Delete shift:=xlUp
Next

' Mise en forme des cellules
Range('AR6:AU20').Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With
Range('A1').Select
Application.ScreenUpdating = True
End Sub
merci A+Marion
 
salut Marion
bonsoir le Forum

peux tu me dire à quoi correspond la partie en gras
Range('BDD').AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
'AQ1:AS2'), CopyToRange:=Range('AR5:AS200'), Unique:=False
Range('BDD').AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
'AT1:AV2'), CopyToRange:=Range('AT5:AU200'), Unique:=False
ActiveWindow.SmallScroll Down:=-15
si celà correspond à une plage nommée il faut enlevé je pense les guillemets sinon dit moi ce que c'est
 
Bonsoir a tous les deux, et a l'ensemble du forum.


Je reviens juste pas eu le temps de regarder en détail.


Baside je ne peut pas te faire passer le fichier il est trop gros.

mais j'ai des problème la macro bug au niveau du BDD enfin je crois.

pour ce soir je vais me coucher car la fatigue est là.

je revois ça demain.



A+Marion


bonne nuit a toutes et a tous
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

Réponses
1
Affichages
180
Réponses
2
Affichages
153
Réponses
4
Affichages
177
  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
479
Réponses
8
Affichages
233
Réponses
4
Affichages
461
Retour