Recopier lignes selon critères
Bonjour
j'ai grand besoin de vos lumières.
j'ai besoin de recopier des valeurs selon un critère. Explications:
j'ai environ 120 personnes qui ont répondu plusieurs fois à un questionnaire. J'ai besoin de regrouper les réponses de chaque personne dans un onglet à son nom. L'individu IND01 doit voir toutes ses réponses recopier dans un onglet intitulé IND01
Ce même questionnaire va recevoir ultérieurement les réponses d'autres personnes et il faudra que je recommence la même manœuvre. C'est pourquoi j'ai besoin que cette tache soit automatisée.
Merci de ce que vous pourrez me trouver comme solutions
Cordialement
Bonjour le forum,
Essaie ceci :
Option Explicit
Sub test()
Dim a, e, dico As Object, wsName As String
Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
With .Range("a1").CurrentRegion
a = .Columns(1).Offset(1).Resize(.Rows.Count - 1).Value
For Each e In a
If Not dico.exists(e) Then
dico(e) = Empty
wsName = e
If Not Evaluate("isref('" & wsName & "'!a1)") Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
End If
Sheets(wsName).Cells.Delete
.AutoFilter 1, e
.SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Cells(1)
.AutoFilter
End If
Next
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Bonsoir. Merci et respect. Cela fonctionne parfaitement. Cela engendre encore beaucoup de travail qu'il va falloir automatiser et je me demande s'il n'y a pas encore une solution plus rapide. Explications :
Je dois effectuer la moyenne des valeurs pour chaque participant (240 participants) et chaque item (78 items) .
Est ce que sur le même onglet ou dans un autre on peut calculer la moyenne pour chaque item et pour chaque participant voir fichier joint
Merci de vos lumières
Peut être faut-il que j'ouvre une autre conversation pour ce nouveau problème ?
Re pbpb76,
Si tu veux les moyennes en fin de tableaux.
Option Explicit
Sub test()
Dim a, e, dico As Object, wsName As String
Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
With .Range("a1").CurrentRegion
a = .Columns(1).Offset(1).Resize(.Rows.Count - 1).Value
For Each e In a
If Not dico.exists(e) Then
dico(e) = Empty
wsName = e
If Not Evaluate("isref('" & wsName & "'!a1)") Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
End If
Sheets(wsName).Cells.Delete
.AutoFilter 1, e
.SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Cells(1)
With Sheets(wsName).Cells(1).CurrentRegion
With .Rows(.Rows.Count + 1)
.Cells(1) = "Moyennne"
With .Cells(2).Resize(, .Columns.Count - 1)
.Formula = "=average(r2c:r[-1]c)"
.NumberFormat = "0.00"
End With
.Interior.ColorIndex = 19
.BorderAround Weight:=xlThin
End With
With .Rows(1)
.Interior.ColorIndex = 43
.BorderAround Weight:=xlThin
End With
With .Resize(.Rows.Count + 1)
.Font.Name = "calibri"
.Font.Size = "10"
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
End With
End With
.AutoFilter
End If
Next
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Gloire à toi. Tu n'imagines pas le bénéfice en terme d'heures de travail que tu me fais gagner. Merci encore
Re pbpb76,
Si tu veux les moyennes en fin de tableaux.
Option Explicit Sub test() Dim a, e, dico As Object, wsName As String Application.ScreenUpdating = False Set dico = CreateObject("Scripting.Dictionary") With Sheets("Feuil1") With .Range("a1").CurrentRegion a = .Columns(1).Offset(1).Resize(.Rows.Count - 1).Value For Each e In a If Not dico.exists(e) Then dico(e) = Empty wsName = e If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName End If Sheets(wsName).Cells.Delete .AutoFilter 1, e .SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Cells(1) With Sheets(wsName).Cells(1).CurrentRegion With .Rows(.Rows.Count + 1) .Cells(1) = "Moyennne" With .Cells(2).Resize(, .Columns.Count - 1) .Formula = "=average(r2c:r[-1]c)" .NumberFormat = "0.00" End With .Interior.ColorIndex = 19 .BorderAround Weight:=xlThin End With With .Rows(1) .Interior.ColorIndex = 43 .BorderAround Weight:=xlThin End With With .Resize(.Rows.Count + 1) .Font.Name = "calibri" .Font.Size = "10" .VerticalAlignment = xlCenter .Borders(xlInsideVertical).Weight = xlThin .BorderAround Weight:=xlThin End With End With .AutoFilter End If Next End With End With Set dico = Nothing Application.ScreenUpdating = True End Subklin89
Bonjour
Si Klin89 a encore des miracles de disponible avec ses codes VBA, je suis preneur. J'ai présenté à l'équipe pédagogique les possibilités offertes par le code VBA écrit par Klin 89. Succès évidemment. Cela a suscité de nouvelles demandes complémentaires.
- Les commentaires récoltés auprès des évaluateurs doivent faire l'objet d'un retour auprès des personnes évaluées. Ils doivent donc être rassemblés (Concatener dans excel ?)
- Il ne faut envoyer les évaluations que si un nombre suffisant d'évaluations a été effectué. Il faut donc compter le nombre d'évaluation par personne évaluée.
- Ces données doivent être ensuite disposées dans un tableur Google Sheets afin d'être envoyé par publipostage avec Yamm dans Gmail. Il faut donc que toutes ces données soient rassemblées sur une seule feuille
Exemple en fichier joint
Cordialement
Précisions je vais avoir à traiter environ 200 évaluées sur 72 items
je ne sais plus si j'ai mis le fichier montrant ce que je souhaiterais au final. Je vous le reme
ts