calcul récurrent dans tableau

CAFRINE

XLDnaute Nouveau
Bonjour à tous,

un probleme dans mon fichier...
a chaque modification d'une celulle dans mon tableau
un calcul ( en plusieurs fois ) se fait ..
un peu de mal a expliquer !!!
fichier joint
ex: entrer une donnée en B7 et valider..

merci de votre aide

cafrine
 

Pièces jointes

  • Copie de.xls
    89.5 KB · Affichages: 61
  • Copie de.xls
    89.5 KB · Affichages: 78
  • Copie de.xls
    89.5 KB · Affichages: 76

kjin

XLDnaute Barbatruc
Re : calcul récurrent dans tableau

bonsoir,
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lig%, nblig%, i As Byte
ActiveSheet.Unprotect
If Not Intersect(Target, Range("B5:B500")) Is Nothing Then Target = UCase(Target)
If Not Intersect(Target, Range("C5:C500")) Is Nothing Then Target = LCase(Target)
If Not Intersect(Target, Range("D5:D500")) Is Nothing Then Target = UCase(Target)
If Target.Column = 13 And UCase(Target) = "X" Then
    lig = Target.Row
    With Sheets("Archives")
        nblig = .Range("B65535").End(xlUp).Row + 1
        For i = 2 To 14
            .Cells(nblig, i).Value = Cells(lig, i).Value
        Next i
        .Cells(nblig, 1) = Now 'je suppose !
    End With
    Application.EnableEvents = False
    Rows(lig).EntireRow.Delete
    Application.EnableEvents = True
End If
ActiveSheet.Protect
End Sub
A+
kjin
 

ROGER2327

XLDnaute Barbatruc
Re : calcul récurrent dans tableau

Bonsoir à tous.


Ça devrait aller mieux comme ceci :​
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lig&
    Dim nblig&
    Dim DerLigne&
    Dim i As Byte

    ActiveSheet.Unprotect

    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With

    If Not Intersect(Target, Range("B5:B500")) Is Nothing Then Target = UCase(Target)
    If Not Intersect(Target, Range("C5:C500")) Is Nothing Then Target = LCase(Target)
    If Not Intersect(Target, Range("D5:D500")) Is Nothing Then Target = UCase(Target)

    If Left(Target.Address, 2) = "$M" Then
        If UCase(Target.Value) = "X" Then
            lig = Target.Row
            nblig = Sheets("Archives").Range("B65535").End(xlUp).Row + 1
            For i = 2 To 14
                Sheets("Archives").Cells(nblig, i).Value = Cells(lig, i).Value
            Next i
            Rows(lig).Delete Shift:=xlUp
        End If
    End If


    Sheets("base").Cells(1, 1).Activate
    Application.ScreenUpdating = True
    Sheets("Archives").Range("a65535").End(xlUp) = Now

    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With

    ActiveSheet.Protect

End Sub
Cela étant, je ne sais pas si le résultat est celui qui est escompté : il faudrait pour cela que le but de la manœuvre fût expliqué...​



ROGER2327
#6426


Samedi 7 Gueules 140 (Saint Gueule, abbé - fête Suprême Quarte)
13 Pluviôse An CCXXI, 9,7532h - laurier
2013-W05-5T23:24:27Z
 

Discussions similaires

Réponses
16
Affichages
851

Statistiques des forums

Discussions
312 853
Messages
2 092 822
Membres
105 539
dernier inscrit
Morgane0202