compteur recapitulatif

[silverjet]

bonjour le forum

je sollicite votre aide car :

j ai des donnees dans une feuille que je voudrai quelles se reportent dans une autre en comptant
je joint un bout de fichier pour me faire comprendre



merci

 

[job75]

Re : compteur recapitulatif

Bonjour silverjet,

Merci pour le fichier, mais pas compris grand'chose.

A priori il semble que vous voulez supprimer les doublons de noms, mais compter quoi ???

Et quid des champs nom2 et date

A+

 

[kllmoon]

Re : compteur recapitulatif

Je ne comprends pas du tout ton fichier joint...

 

[silverjet]

Re : compteur recapitulatif

ok
alors voila: je voudrai que mes donnees de la feuille 1 soit transferees dans la feuile 2 dans chaque ligne approprie c a d :

devant chaque nom ex: aa il y a le nombre de fois u,o,p,n e ...

sauf pour les autres colonnes seul les plus recent apparé

jespere etre plus claire
(si possible en VBA car je vais l integrer a mon usf de saisie)
merci

 

[job75]

Re : compteur recapitulatif

Re,

Ben là c'est encore moins clair.

devant chaque nom ex: aa il y a le nombre de fois u,o,p,n e ...

Dans les 2 feuilles les noms sont en 1ère colonne...

A+

 

[silverjet]

Re : compteur recapitulatif

alors voila : j ai un formlaire de saisie qui me fait renseigner les colonnes de la feuil1),

et donc je veux renseigner la feuil2 avec ses infos c a d devant chaque noms (colonne nom) dans les colonnes u,o,p,m..............x le nombre de 0 et de 1 .

merci

 

[job75]

Re : compteur recapitulatif

Re,

Voyez si le fichier joint vous convient.

Pour transférer une ligne, double-clic dessus :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim derlig As Long, nom$, tablo(1 To 16), i As Long, j As Byte, ref As Range
derlig = [A65536].End(xlUp).Row
If Target.Row < 6 Or Target.Row > derlig Then Exit Sub
Cancel = True
nom = Cells(Target.Row, 1)
'---Constitution du tableau---
tablo(1) = nom
For i = 6 To derlig
  If Cells(i, 1) = nom Then
    tablo(2) = Cells(i, 2)
    tablo(3) = Cells(i, 3)
    tablo(16) = Cells(i, 16)
    For j = 4 To 15
      tablo(j) = tablo(j) + Cells(i, j)
    Next
  End If
Next
'---Transfert en Feuil2---
Set ref = Sheets("Feuil2").[A5:A65536].Find(nom, LookIn:=xlValues, LookAt:=xlWhole)
If ref Is Nothing Then Set ref = Sheets("Feuil2").[A65536].End(xlUp)(2)
ref.Resize(, 16) = tablo
End Sub

A+

 

[silverjet]

Re : compteur recapitulatif

bonjour a tous
voila ,ce code me convient mais comment je peut inclure ce code dans un usf une fois que je valide sur un bouton ?
merci

 

[silverjet]

Re : compteur recapitulatif

desolé je ne me suis pas relu!!!

en fait ce que j voudrai c est dans un usf avec un boutton de validation ,quand je valide cela me fait l action du code de job75 .

(sans double cliquer)


merci

 

[job75]

Re : compteur recapitulatif

Bonjour silverjet, le forum,

Une seule donnée suffit pour transférer une ligne.

Une InputBox est donc bien suffisante :

Private Sub CommandButton1_Click()
Dim nom$, v, tablo(1 To 16), i As Long, j As Byte, ref As Range
[COLOR="Red"]1 nom = InputBox("Entrer le nom à transférer :", "Transférer", nom)[/COLOR]
If nom = "" Then Exit Sub
v = Application.Match(nom, [A6:A65536], 0)
If IsError(v) Then MsgBox "Nom introuvable...": GoTo 1
v = v + 5
'---Constitution du tableau---
tablo(1) = nom
For i = v To [A65536].End(xlUp).Row
  If Cells(i, 1) = nom Then
    tablo(2) = Cells(i, 2)
    tablo(3) = Cells(i, 3)
    tablo(16) = Cells(i, 16)
    For j = 4 To 15
      tablo(j) = tablo(j) + Cells(i, j)
    Next
  End If
Next
'---Transfert en Feuil2---
Set ref = Sheets("Feuil2").[A5:A65536].Find(nom, LookIn:=xlValues, LookAt:=xlWhole)
If ref Is Nothing Then Set ref = Sheets("Feuil2").[A65536].End(xlUp)(2)
ref.Resize(, 16) = tablo
End Sub

Fichier joint.

A+

 

[silverjet]

Re : compteur recapitulatif

bonjour


merci job75 j ai test et cela me convient

encore merci

 

[job75]

Re : compteur recapitulatif

Bonjour silverjet,

Une autre solution avec une liste de validation en C3, sans doublons :

Private Sub Worksheet_Change(ByVal Target As Range)

'---Création de la liste des noms sans doublons---
If Target.Column = 1 Then
Dim d, cel As Range
Set d = CreateObject("Scripting.Dictionary")
For Each cel In Range("A6", [A65536].End(xlUp))
  If Not d.exists(cel.Value) Then d.Add cel.Value, cel.Value
Next
[Q:Q].ClearContents
[Q1].Resize(d.Count) = Application.Transpose(d.Items)
[COLOR="Red"][Q:Q].Sort Key1:=[Q1], Order1:=xlAscending, Header:=xlNo[/COLOR]
End If

If Target.Address = "$C$3" Then
Dim v, tablo(1 To 16), i As Long, j As Byte, ref As Range
v = Application.Match(Target, [A6:A65536], 0)
If IsError(v) Then Exit Sub
'---Constitution du tableau---
tablo(1) = Target
For i = v + 5 To [A65536].End(xlUp).Row
  If Cells(i, 1) = Target Then
    tablo(2) = Cells(i, 2)
    tablo(3) = Cells(i, 3)
    tablo(16) = Cells(i, 16)
    For j = 4 To 15
      tablo(j) = tablo(j) + Cells(i, j)
    Next
  End If
Next
'---Transfert en Feuil2---
Set ref = Sheets("Feuil2").[A5:A65536].Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
If ref Is Nothing Then Set ref = Sheets("Feuil2").[A65536].End(xlUp)(2)
ref.Resize(, 16) = tablo
End If

End Sub

Edit : ajouté tri sur la colonne Q (en rouge)

A+