calcul récurrent dans tableau

[CAFRINE]

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

 

[kjin]

Re : calcul récurrent dans tableau

bonsoir,

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

 

[CAFRINE]

Re : calcul récurrent dans tableau

bonsoir,
bien que cela fonctionnait bien avant,
je me doutais çà provenait de cette macro.
ou se situe l'erreur ?
merci beaucoup KJIN,
bonne soirée au forum

 

[ROGER2327]

Re : calcul récurrent dans tableau

Bonsoir à tous.

Ça devrait aller mieux comme ceci :​

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