Reporter plusieurs valeurs selon un critère

**benzot** · 20/11/2013, 01h08

Bonsoir, Bonjour

En ce moment, je galère à trouver une solution en vba à mon problème, mais sans vraiment de résultats.

je cherche à reporter automatiquement des valeurs fixes contenus dans un tableau de données situé dans la feuille de travail vers un autre tableau de cette feuille.

Sur cette feuille, se trouve donc 3 tableaux (40 lignes et 6 colonnes chacun) avec sous chacun d'eux les tableaux de données respectif.

la ou sera reporter les valeurs (tableau supérieur), la première colonne sera sous liste déroulante (les noms insères dans les listes déroulantes correspond également à la 1ere colonne du tableau de données (plus bas).

Dès lors, que la valeur de la liste est choisies sur une des lignes (1ère colonne), je souhaiterais reporter les valeurs du tableau de données dans les colonnes de droite.

Si la valeur de la 1ére colonne est changer par la suite que les colonnes de droites changes également etc...

1ere colonne : du texte
2->4 colonnes : valeur numériques avec 1 seul chiffre après la virgule
5 colonne : une lettre

dans certaines lignes certaines cellules sont vides.

J'ai essayé de commencer en faisant des copier coller et en attribuant la macro à la cellule ou se trouve les listes déroulante mais ca bug.

recherchev limité

J'ai besoin d'un bon coup de pouce en espérant que l'explication est compréhensible.

Merci

**nibledispo** · 20/11/2013, 04h35

bonjour,

Si j'ai bien compris :
- tu as 3 tableaux supérieurs et 3 tableaux de données inférieurs.
- si l'information sélectionnée dans la 1ère colonne d'un tableau supérieur est trouvée dans la 1ere colonne du tableau de données inférieur qui lui correspond alors toutes les informations situées à droite de la 1ére colonne du tableau inférieur sont recopiées dans le tableau supérieur à droite de la sélection .

c'est ça ?

cordialement,

**casefayere** · 20/11/2013, 09h40

Bonjour,

si j'ai compris ,essayes ce fichier

**nibledispo** · 20/11/2013, 14h44

Bonjour casefayere et autres membres,

Ce que tu as fait correspond à ce que j'ai compris.

Pour ma part j'avais retenu ceci afin d'éviter une multitude de formules dans des lignes vides.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
Sub worksheet_change(ByVal target As Range)
Dim result As Range
 
   'Application.DisplayAlerts = False
   If Not Intersect(Columns("a"), target) Is Nothing Then
   Set result = Range("A22:A28").Find(What:=target.Value, LookIn:=xlValues)
 
   If result Is Nothing Then
      MsgBox "élément nouveau"
   Else
      Application.EnableEvents = False
      target.Offset(0, 1) = result.Offset(0, 1)
      target.Offset(0, 2) = result.Offset(0, 2)
      target.Offset(0, 3) = result.Offset(0, 3)
      target.Offset(0, 4) = result.Offset(0, 4)
      Application.EnableEvents = True
   End If
   End If
   'Application.DisplayAlerts = True
End Sub

Le renvoie se fait bien mais une modification ultérieure dans la base ne sera pas prise en compte.
c'est pourquoi j'avais penser à passer par "formula". Hélas je bute toujours sur une erreur.

Quelqu'un voit-il la solution.

le code ne traite pour l'instant qu'un tableau.

Cordialement?

**benzot** · 21/11/2013, 04h32

Excellent, merci pour votre aide

Nibledispo, c'est exactement ce que je cherche
J'ai testé (le fichier "aaaa") ca fonctionne parfaitement

je n'ai pas d'erreur et la base de données lorsqu'elle est modifier cela fonctionne correctement

Pour le faire fonctionner sur 3 tableaux en tout, vous avez une solution efficace ?

casefayere, pareil,ca fonctionne aussi bien, c'est plus fastidieux mais je garde aussi votre fichier

**nibledispo** · 21/11/2013, 12h18

Bonjour,

Mon code est loin d'être satisfaisant.
Comme je le soulignais, si une valeur est changée dans la base de données, cette modification ne se répercute pas sur le tableau supérieur.
Essai de mettre une lettre à la place d'une autre et tu le constateras.

Sinon, je pense que cela ne devrait pas présenter une grande difficulté de le généraliser aux trois tableaux.
Avant cela, penses tu qu'il soit bien utile de conserver les trois bases de données ? Leurs données sont-elles de nature si différentes qu'elles ne puissent-être groupées ?

Cordialement,

**benzot** · 21/11/2013, 12h35

Bonjour,

effectivement, mais le rafraichissement du tableau suite a la modification de la base est pas si grave car j'ai posé un bouton dans le tableau qui efface le tableau supérieur et normalement le tableau de données ne changera pas.

Pour la suite, je pense à la vue du résultat satisfaisant de votre code (a voir si faisable).

j'aurai finalement besoin de 2 bases de données par tableaux

et sur 7 feuilles
(car valeurs # dans la même cellule, selon le critère choisi sur la ligne)

explications:

COL1 --- COL2 --- COL3 --- COL4 --- COL5 --- COL6 --- COL7

COL1= critère à choisir qui reporte comme votre code (laisse la COL2 vide).

COL2= critère à choisir seulement si dans la COL1 l'utilisateur choisi un seul critère (texte) spécifique (si qui active une liste déjà prédéfinie dans validation de données), puis reporte des valeurs à droite.
COL3 à COL7 = valeurs a reporter de la base de données

J'espère que c'est assez clair

Merci encore

Ce soir, je testerai également la manipulation pour le faire sur 3 tableaux.

**nibledispo** · 21/11/2013, 15h11

Re....,

Voici le fichier généralisé à trois tableaux.

Pour le reste, je ne suis pas sur d'avoir tout compris.

J’essaierai de voir ce soir.

a+ ,

**nibledispo** · 22/11/2013, 06h03

Bonjour,

Le fichier joint correspond t-il à ta dernière demande.

Sur ce fichier :
- Saisir d'abord la première colonne. Au demeurant tu ne pourras pas saisir ailleurs (protection).
- Saisir la colonne 2 sur demande message (si rien de prévu ne rien saisir).

Cordialement,

**benzot** · 26/11/2013, 09h58

Bonjour,

Fonctionne super bien

merci

Sur la dernière version, peut-on faire ouvrir sur une condition (texte précis) l'inputbox ou changer celui-ci ? (userform ou liste déroulante afin d'avoir une liste de critères, au lieu de taper un texte)

J'ai adapter sans soucis votre code, mais j'ai 2 soucis :
-J'ai pas réussi à trouver la solution afin que les cellules copiées ne changent pas la mise en forme du tableau supérieur.

-j'ai des boutons activex (private sub) sur cette feuille qui changent le texte dans la première colonne de chaque tableau mais maintenant lorsque j'appui dessus j'ai l'inputbox du code qui s'ouvre juste apres (valider ou non ,j'ai une erreur du code ressort):

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If target.Offset(0, 1).Value <> "" Then

même en changeant l'offset j'ai l'inputbox et l'erreur
(les cellules de données commencent en B150 et en B215 et Intersect dans le code commence en B10/N10/Z10).

**nibledispo** · 26/11/2013, 14h37

Bonjour,

Pour la première question, je pense que c'est possible.

Pour le reste, il m'est difficile de répondre sans avoir le fichier et notamment la position sur la feuille des activex et du code qui l'accompagne, .

Cordialement,

**benzot** · 26/11/2013, 16h13

Bonjour,

voila une copie basique du fichier (une fois retirée données privées)

j'espère que vous aurez toute les infos nécessaires.

TEST Copie.xls

CDT

**nibledispo** · 27/11/2013, 22h40

Bonsoir,

En pièce jointe le fichier à tester.

J'ai remplacé le message par une validation des données en colonne C.

Attention tes validations ont fausses sur les deux autres tableaux, ce qui provoque des erreurs.

Au demeurant, je ne comprends pas pourquoi tu ne vas pas chercher les donnée directement sur l'autre feuille plutôt que de recopier celles-ci.

Tout cela me semble bien confus.

cordialement,

**benzot** · 02/12/2013, 22h05

Bonsoir,

Merci beaucoup pour le code

je l'ai tester et c'est encore mieux

J'ai tester dans mes 3 tableaux et lorsque que le texte est sélectionné (soit dans la 1er ou 2eme colonne) ca renvoi bien les bonnes valeurs.

-Est ce que la protection de la feuille est obligatoire car cela bloque mes spinbuttons ? (pas vu comment pour les laisser actifs et boutons activex ras).

-j'ai toujours une erreur de type 13 à la ligne worksheet (If target.Offset(0, 1) = "" Then)
lorsque j'appui sur un bouton activex (il copie une nouvelle liste dans la 1er colonne puis vide le tableau).

Sinon encore merci

Tu pense qu'il y a une façon plus simple afin d'éviter de copier les données du bas dans le ou les tableaux ? je suis preneur

**nibledispo** · 03/12/2013, 07h12

Bonjour,

Non la protection n'est pas obligatoire. c'est uniquement un choix de précaution.

Le problème lié aux boutons provient de ce que les procédures liés à ces boutons effacent des données dans les colonnes target.

Pour pallier le problème interdire le passage sur la procédure worksheet comme suit:

mettre dans la procédure worksheet ....

juste avant le premier if

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
if passe = 1 then alors exit sub

mettre avant la procédure worksheet.... (déclaration valable pour toutes les procédures)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
dim passe as byte

mettre dans chaque procédure liée aux boutons
- en première instruction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
passe = 1

- en dernière instruction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
passe = 0

cordialement,

**benzot** · 04/12/2013, 03h44

Bonsoir,

J'ai suivi votre aide, mais j'ai encore l'erreur ?

le code suivant ressort le mot "exit" en erreur expression (si "alors" enlevé plus d'erreur d'expression)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if passe = 1 then alors exit sub

Ce code est-il bien placé ? :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Sub worksheet_change(ByVal target As Range)
 
Dim passe As Byte
Dim result As Range
Dim Prelig1 As Long, Derlig1 As Long
Dim col2 As String
 
If passe = 1 Then Exit Sub
 
Set DebBD1 = Range("B149")
Prelig1 = DebBD1.Row
Derlig1 = DebBD1.End(xlDown).Row
 
Set DebBD2 = Range("B215")
Prelig2 = DebBD2.Row
Derlig2 = DebBD2.End(xlDown).Row
 
   If Not Intersect(Range("B12:B" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("N12:N" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("Z12:Z" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("C12:C" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("O12:O" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("AA12:AA" & Prelig1 - 4), target) Is Nothing Then
 
     col = target.Column
      ActiveSheet.Unprotect
      'Application.EnableEvents = False
      If (target.Column = 3 Or target.Column = 15 Or target.Column = 27) Then
         If target.Value <> "" Then
            Set result = Range(Cells(Prelig2, col - 1), Cells(Derlig2, col - 1)).Find(What:=target.Value, LookIn:=xlValues)
            Range(Cells(target.Row, col + 1), Cells(target.Row, col + 5)).Value = Range(Cells(result.Row, col + 1), Cells(result.Row, col + 5)).Value
         Else
            Set result = Range(Cells(Prelig1, col - 1), Cells(Derlig1, col - 1)).Find(What:=target.Offset(0, -1).Value, LookIn:=xlValues)
            Range(Cells(target.Row, col + 2), Cells(target.Row, col + 6)).Value = Range(Cells(result.Row, col + 2), Cells(result.Row, col + 6)).Value
         End If
      End If
 
      If (target.Column = 2 Or target.Column = 14 Or target.Column = 26) Then
         If target.Offset(0, 1) = "" Then
            Set result = Range(Cells(Prelig1, col), Cells(Derlig1, col)).Find(What:=target.Value, LookIn:=xlValues)
            Range(Cells(target.Row, col + 2), Cells(target.Row, col + 6)).Value = Range(Cells(result.Row, col + 2), Cells(result.Row, col + 6)).Value
         Else
            Set result = Range(Cells(Prelig2, col), Cells(Derlig2, col)).Find(What:=target.Offset(0, 1).Value, LookIn:=xlValues)
            Range(Cells(target.Row, col + 2), Cells(target.Row, col + 6)).Value = Range(Cells(result.Row, col + 2), Cells(result.Row, col + 6)).Value
         End If
      End If
      'Application.EnableEvents = True
 
      ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   End If
End Sub

Pour les boutons , un exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub Groupe_LA2_Click()
Dim passe As Byte
If MsgBox("Effacera toute les données", vbYesNo + vbQuestion, "1") = vbYes Then
ActiveSheet.Unprotect
passe = 1
With Sheets("LUNDI")
.Range("M9") = "1"
Sheets("REGLAGES").Range("A2:A15").Copy
.Range("M12:M25").PasteSpecial Paste:=xlPasteValues
.Range("N12:V25").ClearContents
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
passe = 0
End Sub

merci

**nibledispo** · 04/12/2013, 10h05

bonjour,

comme ceci.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Dim passe As Byte  ' avant la sub pour être reconnue dans toutes les proédures
Sub worksheet_change(ByVal target As Range)
 
Dim result As Range
Dim Prelig1 As Long, Derlig1 As Long
Dim col2 As String
 
If passe = 1 Then Exit Sub
 
Set DebBD1 = Range("B149")
Prelig1 = DebBD1.Row
Derlig1 = DebBD1.End(xlDown).Row
 
Set DebBD2 = Range("B215")
Prelig2 = DebBD2.Row
Derlig2 = DebBD2.End(xlDown).Row
 
   If Not Intersect(Range("B12:B" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("N12:N" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("Z12:Z" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("C12:C" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("O12:O" & Prelig1 - 4), target) Is Nothing _
   Or Not Intersect(Range("AA12:AA" & Prelig1 - 4), target) Is Nothing Then
 
     col = target.Column
      ActiveSheet.Unprotect
      'Application.EnableEvents = FalseIf passe = 1 Then Exit Sub
      If (target.Column = 3 Or target.Column = 15 Or target.Column = 27) Then
         If target.Value <> "" Then
            Set result = Range(Cells(Prelig2, col - 1), Cells(Derlig2, col - 1)).Find(What:=target.Value, LookIn:=xlValues)
            Range(Cells(target.Row, col + 1), Cells(target.Row, col + 5)).Value = Range(Cells(result.Row, col + 1), Cells(result.Row, col + 5)).Value
         Else
            Set result = Range(Cells(Prelig1, col - 1), Cells(Derlig1, col - 1)).Find(What:=target.Offset(0, -1).Value, LookIn:=xlValues)
            Range(Cells(target.Row, col + 2), Cells(target.Row, col + 6)).Value = Range(Cells(result.Row, col + 2), Cells(result.Row, col + 6)).Value
         End If
      End If
 
      If (target.Column = 2 Or target.Column = 14 Or target.Column = 26) Then
         If target.Offset(0, 1) = "" Then
            Set result = Range(Cells(Prelig1, col), Cells(Derlig1, col)).Find(What:=target.Value, LookIn:=xlValues)
            Range(Cells(target.Row, col + 2), Cells(target.Row, col + 6)).Value = Range(Cells(result.Row, col + 2), Cells(result.Row, col + 6)).Value
         Else
            Set result = Range(Cells(Prelig2, col), Cells(Derlig2, col)).Find(What:=target.Offset(0, 1).Value, LookIn:=xlValues)
            Range(Cells(target.Row, col + 2), Cells(target.Row, col + 6)).Value = Range(Cells(result.Row, col + 2), Cells(result.Row, col + 6)).Value
         End If
      End If
      'Application.EnableEvents = True
 
      ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   End If
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub Groupe_LA2_Click()
Dim passe As Byte    ' ne sert à rien - à supprimer
If MsgBox("Effacera toute les données", vbYesNo + vbQuestion, "1") = vbYes Then
ActiveSheet.Unprotect
passe = 1
With Sheets("LUNDI")
.Range("M9") = "1"
Sheets("REGLAGES").Range("A2:A15").Copy
.Range("M12:M25").PasteSpecial Paste:=xlPasteValues
.Range("N12:V25").ClearContents
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
passe = 0
End Sub

Cordialement,

**benzot** · 05/12/2013, 00h22

Bonjour

Très efficace

Ca se finalise, mais j'ai une dernière question

ca fonctionne nickel mais j'ai une erreur exécution 91 à 2 moments:
lorsque je supprime manuellement une valeur dans les colonnes de sélection ou lorsque je fais un double click dans les cellule vide de sélection.

peut-on éviter cette erreur ?
voir bloquer la suppression de la cellule manuellement ? tout en laissant la liste déroulante opérationnelle ?

le mieux est ce une liste via la validation de données ou en vba ?

Merci encore

**nibledispo** · 05/12/2013, 04h01

Bonjour,

La réponse est évidente: ajouter 1 à derlig1 et derlig2. Cette ligne ajouté est vide de contenu puisqu'elle vient après la dernière valeur valide.
Ainsi VBA considère la valeur "" comme valide.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Derlig1 = DebBD1.End(xlDown).Row + 1


Derlig2 = DebBD2.End(xlDown).Row + 1

bien entendu, il te faudra étendre ta boite de validation à la ligne ajoutée.

**benzot** · 07/12/2013, 21h00

Nickel au top

Merci encore et encore

Bon pour noël, j'achète des bouquins sur la programmation.

Je ne suis pas au niveau, mes bases sont insuffisantes.

et super site plein d'outils et forum de pro

A bientôt

Reporter plusieurs valeurs selon un critère

Macros et VBA Excel

Discussions similaires

Partager

Partager