Modifier d'un code

[maval]

Bonjour,

J'ai un Formulaire pour calculer les point d'un concours de belote, qui a était réaliser par Job75 que je salut et remercie au passage.
J'aimerai lui apporter une modification. J'aimerai lui a ajouter ce code ci-dessous pour les quatre feuilles à savoir:"1erTours, 2émeTours, 3émeTours, et 4émeTours".

Dim r As Range, v As Variant
Set r = Intersect(Target, Range("G3:J" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r 'en cas d'entrées/effacements multiples
  If r.Row Mod 2 Then
    r(2) = IIf(r = "", "", 1944 - Val(r))
  Else
    v = IIf(r(0) = "", "", 1944 - Val(r(0)))
    If r <> v Then r = v
  End If
Next

En sachant qu'il y a déjà se code dans le ThisWoorkBook

Option Explicit

'Pour que les 4 feuilles soient renseignées et triées
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim n As Integer, w As Worksheet, F As String

If Sh.Name = "Classement" Then
  'pour que les 4 feuilles soient renseignées et triées
  For n = 1 To 4
    For Each w In Worksheets
      If Val(w.Name) = n Then
        Workbook_SheetActivate w
        Workbook_SheetDeactivate w
        If n = 4 Then Exit For 'conserve w
      End If
    Next
  Next
  'calcul à partir de la feuille n° 4
  With w
    .[B3:B200,D3:E200].Copy Sh.[C3]
    F = "=IF(COUNT('" & .Name & "'!RC7:RC10),SUM('" & .Name & "'!RC7:RC10),"""")"
  End With
  Sh.[F3:F200].FormulaR1C1 = F
  Sh.[F3:F200] = Sh.[F3:F200].Value
End If

n = Val(Sh.Name) - 1
If n < 1 Then Exit Sub
If Application.Count(Sh.[G3:G200].Offset(, n)) Then Exit Sub
For Each w In Worksheets
  If Val(w.Name) = n Then w.Cells.Copy Sh.[A1]: Exit For
Next
Sh.[A1].Copy Sh.[A1] 'vide le presse-papier

End Sub

'Calculer sur la feuille classement
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
'---classement---
If Val(Sh.Name) = 0 Then Exit Sub
'la colonne F est utilsée pour le calcul
Sh.[F3:F200].FormulaR1C1 = "=SUM(RC7:RC10)"
Sh.[B3:J200].Sort Sh.[F3], xlDescending, Header:=xlNo
Sh.[F3:F200].ClearContents
End Sub

D'avance merci à qui pourra m'aider.
Cordialement

Maval

 

[job75]

Re : Modifier d'un code

Bonjour maval,

Le 2ème code concerne les macros Workbook_SheetActivate et Workbook_SheetDeactivate.

Il faut mettre le 1er code dans la macro Workbook_SheetChange :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
Dim r As Range, v As Variant
If Val(Sh.Name) = 0 Then Exit Sub
Set r = Intersect(Source, Sh.Range("G3:J" & Rows.Count), Sh.UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r 'en cas d'entrées/effacements multiples
  If r.Row Mod 2 Then
    r(2) = IIf(r = "", "", 1944 - Val(r))
  Else
    v = IIf(r(0) = "", "", 1944 - Val(r(0)))
    If r <> v Then r = v
  End If
Next
End Sub

Toujours dans ThisWorkbook.

A+

 

[maval]

Re : Modifier d'un code

Bonjour Job

Super je te remercie beaucoup.

J'ai mis un bouton pour effacer les les 4 quatre feuille à savoir:"1erTours, 2émeTours, 3émeTours, et 4émeTours". Avec le code ci-dessous. Je voulais connaitre tu avis sur ce code merci beaucoup et bonne journée.

Sub Effaces(Niveau As Integer)
 Sheets("1erTours").Select
 Range("D3:G200").Select
    Selection.ClearContents
    
  'Effacer le deuxieme niveau "feuille"
  If Niveau < 4 Then
        Sheets("2émeTours").Select
    Range("D3:H200").Select
   ' Range("L3:M200").Select
    Selection.ClearContents
   End If
   
    'Effacer le troisiéme niveau "feuille"
  If Niveau < 4 Then
        Sheets("3émeTours").Select
    Range("D3:I200").Select
   ' Range("L3:M200").Select
    Selection.ClearContents
    End If
    
      'Effacer le quatriémeniveau "feuille"
  If Niveau < 4 Then
        Sheets("4émeTours").Select
    Range("D3:J200").Select
   ' Range("L3:M200").Select
    Selection.ClearContents
    End If
    
      'sélectionne une autre cellule
 Range("I1").Select
    
End Sub
Sub Efface_Tous()
    Application.EnableEvents = False
    reponse = MsgBox("Vous allez effacer tous les résultats." & Chr(10) & Chr(10) & "Voulez-vous continuer?", vbOKCancel, "Attention")
    If reponse = vbOK Then Effaces 0
    Application.EnableEvents = True
End Sub

@+

Max

 

[job75]

Re : Modifier d'un code

Re,

Vous ne vous êtes jamais aperçu qu'en VBA on n'utilise (presque) jamais les Select et autre Activate ?

A+

 

[maval]

Re : Modifier d'un code

Re,

Je ne le savais pas merci pour l'avenir?

@+

Max