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?
 

Discussions similaires


Haut Bas