rajout dans une macro ?

Question

Bonjour,
voilà mon problème :
j'ai une application déjà bien finalisée, mais il me manque un petit quelque chose que j'arrive pas à mettre.
j'ai une colonne de A2: A41 avec le rang occupé par les noms
une colonne en B:B41 avec les noms sous forme de liste
une zone combinée qui me permet de sélectionner un nom qui apparait en E17 (pour m'assurer que je ne me suis pas trompé)
ET................une colonne de S2:S41 dans laquelle je voudrais incrémenter +1 à chaque fois que je sélectionne un nom
par ex qd pierre est sélectionné il y aurait 1
si je le sélectionne une 2e fois, il y aurait 2..............;toujours dans la colonne S2:S41, mais au nouveau rang qui est le sien (il apparait dans la cellule E14)

les noms ne gardent pas toujours leur même place; ils évoluent !
voiçi le code que j'ai écrit, mais où puisje mettre le code pour cette incrémentation et comment l'écrire ,


Style = vbOKCancel + vbDefaultButton1
Msg = "Vous allez actualiser le classement de : " & Range("E17")
Title = "Attention ne cliquez qu'une seule fois !"
Réponse = MsgBox(Msg, Style, Title)
If Réponse = vbCancel Then
End
End If
If Réponse = vbOK Then
End If
For Each cell In Range("B2:B41")
If cell.Value = Range("E17") Then
cell.Select
ActiveCell.Offset(0, 1).Select
ActiveCell = Range("E16")
End If
Next
Range("G11").Select
End Sub

mon code fonctionne très bien autrement

merci merci de l'aide

Gord21 · Answer

Bonsoir,

Une première une remarque, tu peux remplacer :
cell.Select 
ActiveCell.Offset(0, 1).Select 
ActiveCell = Range("E16") 
par :
cell.Offset(0, 1).Value = Range("E16") .Value
(le Value est optionnel mais plus explicit)

Ce qui donne dans ton cas :
For Each cell In Range("B2:B41") 
   If cell.Value = Range("E17") Then 
      cell.Offset(0, 1).Value = Range("E16") .Value
      Range("S"& cell.Row).Value=Range("S"& cell.Row).Value+1
   End If 
Next

@+

Gord21 · Answer

Bonsoir,
J'avais pensé à quelque chose comme ça :
Sub Trier()
'
Dim Style, Msg, Title
Dim Reponse
Dim cellule As Range
Dim F_source As Worksheet
Dim F_Temp As Worksheet
'
Set F_source = ActiveSheet
Style = vbOKCancel + vbExclamation
Msg = "Vous allez reclasser tout le groupe ! avez-vous bien actualisé les classements de " & Range("E19")
Title = "Attention !"
Reponse = MsgBox(Msg, Style, Title)
'
If Reponse = vbCancel Then
   End
End If
'
If Reponse = vbOK Then
End If
'
' Création d'une feuille temporaire
Set F_Temp = Sheets.Add
'
' Copie des valeurs
F_source.Range("B2:C37").Copy
F_Temp.Range("A1").PasteSpecial _
   Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
F_source.Range("Q2:Q37").Copy
F_Temp.Range("C1").PasteSpecial _
   Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'
' Tri des données
F_Temp.Range("A1").CurrentRegion.Sort _
   Key1:=Range("B1"), Order1:=xlDescending, _
   Key2:=Range("A1"), Order2:=xlAscending, _
   Key3:=Range("C1"), Order3:=xlAscending, _
   Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'
' Remise en place des valeurs
F_Temp.Range("A1:B36").Copy
F_source.Range("B2").PasteSpecial _
   Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
F_Temp.Range("C1:C36").Copy
F_source.Range("Q2").PasteSpecial _
   Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'
' Effacement de la feuille temporaire
Application.DisplayAlerts = False
F_Temp.Delete
Application.DisplayAlerts = True
'
F_source.Activate
Range("E14").Select
ActiveCell.FormulaR1C1 = "40"
Range("I14").Select
ActiveCell.FormulaR1C1 = "40"
Range("I15").Select
Range("G11").Select
'
End Sub

Rajout dans une macro ?

2 réponses

Discussions similaires

Newsletters