macro extraction données et soustraction

dacyrix

XLDnaute Nouveau
bonjour,
avis aux spécialistes dans la feuille testmacro2 une macro récupère à intervalle régulier un chiffre qui correspond à une masse.Je voudrais faire une sorte de bilan dès que ce chiffre n'apparait plus dans la colonne A
par ex:114 dernière apparition à 18:50 la macro me donnerait la soustraction de la 1ère apparition et de la dernière apparition 114 820t - 852t=-32t dans une autre cellule ou feuille
merci de votre aide
 

Fichiers joints

klin89

XLDnaute Impliqué
Re : macro extraction données et soustraction

Bonsoir dacyrix,

Enlève le module 2 et le Workbook_Open, cela me dérange un peu :mad:
Sous réserve des données fournies dans la feuille "testmacro2", essaie ceci, le résultat s'affiche en Feuil2,

VB:
Sub Calculer_Masse()
Application.ScreenUpdating = False
Dim tablo, coll As Collection
Set coll = New Collection
ReDim tablo(2, 1)
With Sheets("testmacro2")
For n = 12 To .Range("A65536").End(xlUp).Row
  On Error Resume Next
   coll.Add .Range("A" & n), CStr(.Range("A" & n))
  On Error GoTo 0
Next n
For n = 1 To coll.Count
  For m = 12 To .Range("A65536").End(xlUp).Row
    If .Range("A" & m) = coll(n) Then masse = .Range("C" & m) - masse
  Next m
  If masse > 0 Then masse = ""
  'If masse > 0 Then masse = -masse
  tablo(1, n) = coll(n)
  tablo(2, n) = masse
  ReDim Preserve tablo(2, UBound(tablo, 2) + 1)
  masse = 0
Next n
ligne = 1
For n = 1 To UBound(tablo, 2) - 1
  Sheets("Feuil2").Cells(ligne, 1) = tablo(1, n)
  Sheets("Feuil2").Cells(ligne, 2) = tablo(2, n)
  ligne = ligne + 1
Next n
End With
Application.ScreenUpdating = True
End Sub
Un truc me chiffonne, dans la feuille "testmacro2", les valeurs de la colonne(A) n'apparaissent-elles que 2 fois au maximum ?
Le cas ci-dessous peut-il se présenter ?

114 18:48 852 t
114 18:49 820 t
114 18:50 810 t
Le résultat attendu serait alors -10t dans ce cas et non pas -32 t !

Klin89
 
Dernière édition:

klin89

XLDnaute Impliqué
Re : macro extraction données et soustraction

Bonjour le forum,
Bonjour dacyrix,

VB:
Option Base 1

Sub Calculer_Difference_Masse()
'Calcul la différence entre la dernière et avant dernière occurence trouvée
Application.ScreenUpdating = False
Dim tablo, coll As Collection
Set coll = New Collection
ReDim tablo(2, 1)
With Sheets("testmacro2")
  For n = 12 To .Range("A65536").End(xlUp).Row
    On Error Resume Next
      coll.Add .Range("A" & n), CStr(.Range("A" & n))
    On Error GoTo 0
  Next n
  For n = 1 To coll.Count
    For m = 12 To .Range("A65536").End(xlUp).Row
      If .Range("A" & m) = coll(n) Then
        masse2 = masse1
        masse1 = .Range("C" & m)
        difference = masse1 - masse2
      End If
    Next m
    If difference > 0 Then difference = ""
    tablo(1, n) = coll(n)
    tablo(2, n) = difference
    ReDim Preserve tablo(2, UBound(tablo, 2) + 1)
    difference = 0: masse1 = 0: masse2 = 0
  Next n
End With
With Sheets("Feuil2")
  ligne = 1
  For n = 1 To UBound(tablo, 2) - 1
    .Cells(ligne, 1) = tablo(1, n)
    .Cells(ligne, 2) = tablo(2, n)
  ligne = ligne + 1
  Next n
End With
Application.ScreenUpdating = True
End Sub
Le résultat obtenu s'affiche en Feuil2
VB:
Option Base 1

Sub Calculer_Difference_Masse()
'Calcul la différence entre la dernière et première occurence trouvée
Application.ScreenUpdating = False
Dim tablo, coll As Collection
Set coll = New Collection
ReDim tablo(2, 1)
With Sheets("testmacro2")
  DerLiS = .Range("A65536").End(xlUp).Row
  'DerLiS =.Range("A" & Rows.Count).End(xlUp).Row
   Set plage = .Range("A12:A" & DerLiS)
  For n = 12 To DerLiS
    On Error Resume Next
      coll.Add .Range("A" & n), CStr(.Range("A" & n))
    On Error GoTo 0
  Next n
  For n = 1 To coll.Count
    masse2 = plage.Find(coll(n), .Range("A" & DerLiS), , , xlByRows, xlNext).Offset(0, 2).Value
    masse1 = plage.Find(coll(n), , , , xlByRows, xlPrevious).Offset(0, 2).Value
    x = plage.Find(coll(n), .Range("A" & DerLiS), , , xlByRows, xlNext).Row
    y = plage.Find(coll(n), , , , xlByRows, xlPrevious).Row
    difference = masse1 - masse2
    If x = y Then difference = ""
   'If x = y Then difference = masse2
     tablo(1, n) = coll(n)
    tablo(2, n) = difference
    ReDim Preserve tablo(2, UBound(tablo, 2) + 1)
    difference = 0: masse1 = 0: masse2 = 0
  Next n
End With
On Error Resume Next  'au cas où
  Sheets("Feuil2").Range("a1").Resize(UBound(tablo, 2) - 1, 2) = Application.Transpose(tablo)
On Error GoTo 0
'Cette instruction équivaut au bloc ci-dessous
'With Sheets("Feuil2")
'  ligne = 1
'  For n = 1 To UBound(tablo, 2) - 1
'    .Cells(ligne, 1) = tablo(1, n)
'    .Cells(ligne, 2) = tablo(2, n)
'  ligne = ligne + 1
'  Next n
'End With
Application.ScreenUpdating = True
End Sub
Edit : 2 codes = 2 résultats différents

Klin89
 
Dernière édition:

dacyrix

XLDnaute Nouveau
Re : macro extraction données et soustraction

bonsoir Klin89,
merci bcp pour votre contribution cela fonctionne bien cela vous a pris combien de temps à résoudre?
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas