macro de comparaison puis calucul

[ted]

bonjour a tous

je recherche une macro pour pouvoir comparer une valeur en colonne B.
en cas de valeur egales il faut additionner la valeur qui a sur la ligne correspondantes en colonne E.

puis effacer les lignes qui ne sont plus utiles pour ne garder que celles calculés ou les uniques.

euh comment on fait pour attacher les fichiers (imageshack n'est pas accessible actuellement pour moi)?

en espérant avoir ete clair

merci d'avance ted

 

[ted]

en fait c'est juste pour calculer une somme d'item qui sont utilisés plusieurs fois dans différentes opérations.

il me faut donc les commander en une seul fois.

 

[ted]

pourquoi perssonne ne me reponds?
🙁 🙁

pitié aidez moi

 

[ChTi160]

Salut ted
bonjour le forum

ted il ne faut pas désespérer et être patient et tu verras que tu auras des proposition
le fait que l’on ne puisse plus mettre pour le moment de pièce jointe explique aussi cela car il n’est pas évident de reproduire ce que les gens demande

donc si tu le veux,tu me fais un fichier exemple (quelsques lignes)de ce que tu as et de ce que tu veux et tu me l’envoyes mon adresse est dans ma signature

dans l’attente

 

[Hervé]

re

'pitié', tu n'en fait pas trop là ? 🙂


bon, un exemple de code qui devrait apres adaptation faire ce que tu demandes :

Sub Bouton1_QuandClic()
Dim data As New Collection
Dim plage As Range
Dim tablo
Dim c As Range
Dim i As Integer
Dim j As Byte

Set plage = Range('b1:b' & Range('b65536').End(xlUp).Row)

'creation d'une collection sans doublons de la colonne B
For Each c In plage
        On Error Resume Next
        data.Add c, CStr(c)
        On Error GoTo 0
Next c

'renvoi de la collection dans tableau
ReDim tablo(1 To data.Count, 1 To 2)
For i = 1 To data.Count
        tablo(i, 1) = data(i)
Next i

'cumul des données
For Each c In plage
        For i = 1 To UBound(tablo)
                If tablo(i, 1) = c Then
                        tablo(i, 2) = tablo(i, 2) + c.Offset(0, 3)
                End If
        Next i
Next c

'suppression des lignes doublons
For i = plage.Rows.Count To 1 Step -1
        If Application.CountIf(plage, Cells(i, 2)) > 1 Then
                Rows(i).Delete
        End If
Next i

'renvoi des cumuls
For Each c In plage
        For i = 1 To UBound(tablo)
                If tablo(i, 1) = c Then
                        c.Offset(0, 3) = tablo(i, 2)
                End If
        Next i
Next c

End Sub

salut

 

[Hervé]

re

salut chti, content de te voir parmis nous 🙂

a plus

 

[Hervé]

re

tiens, je bégaye du clavier moi 😱

a plus

Message édité par: hervé, à: 27/06/2006 11:24

 

[ted]

merci beaucoup je vais tester si ca marche.
je vous tiens au courant.

 

[ChTi160]

Salut Hervé
je me suis demandé si le 'pitié' s'adressait à moi mais non lol
arff depuis qu'il n'y a plus de fichier joint je fais autre chose car travailler sans exemple n'est pas évident lol
donc je fais autre chose et la je me suis dit il faut que je participe et oupsss y a Hervé

bonne journée

 

[ChTi160]

re
une autre version à la Didier lol
Sub Traitement()
Dim j As Integer
Dim TabTemp As Variant
Dim TabResult As Variant
Dim Derlgn As Long, L As Long, L2 As Long, N As Long
'Charge les données dans un tableau variant temporaire
With Sheets('Feuil1')
Derlgn = .Range('B65536').End(xlUp).Row
TabTemp = .Range(.Cells(1, 1), .Cells(Derlgn, 6)).Value

'Pour chaque ligne du tableau en partant de la 2
For L = 2 To Derlgn
'Si la ligne n'est pas 'topée'
If Not TabTemp(L, 6) Then
N = N + 1
'Pour les lignes qui suivent
For L2 = L + 1 To Derlgn
'Si trouve une correspondance
If TabTemp(L2, 2) = TabTemp(L, 2) Then
TabTemp(L, 1) = TabTemp(L2, 1)
TabTemp(L, 3) = TabTemp(L2, 3)
TabTemp(L, 4) = TabTemp(L2, 4)
'Additionne les quantités
TabTemp(L, 5) = TabTemp(L, 5) + TabTemp(L2, 5)
''Tope' la ligne
TabTemp(L2, 6) = True
End If
Next L2
End If
Next L
'Prépare le tableau des résultats
ReDim TabResult(1 To N, 1 To 5)
N = 0
'Compose le tableau des résultats (= lignes non 'topées')
For L = 2 To Derlgn
If Not TabTemp(L, 6) Then
N = N + 1
For L2 = 1 To 5
TabResult(N, L2) = TabTemp(L, L2)
Next L2
End If
Next L

'Colle les résultats dans la feuille
.Range(.Cells(2, 1), .Cells(Derlgn, 6)).ClearContents
.Range('A2').Resize(UBound(TabResult, 1), UBound(TabResult, 2)) = TabResult
End With
End Sub
je ne sais pas mettre en forme le code Balises pas top
Bonne journée