aide avec un code d'extraction des données à partir d'un tableau

Version imprimable

15/02/2022, 10h08
flooki

1 pièce(s) jointe(s)

aide avec un code d'extraction des données à partir d'un tableau

Pièce jointe 613703
Bonjour,
j'ai essayé de recopier un code et l'adapter a mon besoin , je veux extraire des lignes d'un tableaux , a partir d'un critère sur une colonne , càd de selectionner une valeur dans la liste roulante qui j'ai crée de ( 1 à 54 ) et s'il existe dans la colonne hauteur , vas prendre toute la ligne et le copier dans une autre feuille , mais le code ne marche pas trés bien , et je voudrais aussi de remplacer la liste roulante par une valeur entrée avec un écart .
merci en avance de votre aide

1 pièce(s) jointe(s)

bonjour,
tu as déjà un code pour cibler les valeurs avec écart dans ce code tu peu remplacer la couleur par un lien vers le code d'extraction ...

Pièce jointe 613711

les déclarations

Code:

1
2
3
4
5
6
7
8
9
 
Private LigneNB As Double
Private ValeurOrigin As Integer
Private ValeurMaxi As Integer
Private ValeurMini As Integer
Private ValeurEcart As Integer
Private Data As Integer
'-------------------------- table destination
Private LigneNBDest As Double

le nouveau code ( Extraction )

Code:

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
 
 
Private Sub CommandButton2_Click()
    'nombre de ligne de la table
    LigneNB = Range("F1").End(xlDown).Row
    'les écarts de valeur
    ValeurOrigin = Range("J4").Value
    ValeurEcart = Range("K4").Value
    ValeurMaxi = ValeurOrigin + ValeurEcart
    ValeurMini = ValeurOrigin - ValeurEcart
    'efface les couleurs
    Range("J4").Select
    Selection.Copy
    Range("F2:F" & LigneNB).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("J4").Select
    'boucle
    For n = 2 To LigneNB
        Data = Range("F" & n).Value
        Select Case Data
            Case Is = ValeurOrigin
                ExtraireLigne (n)
            Case Is = ValeurMaxi
                ExtraireLigne (n)
            Case Is = ValeurMini
                ExtraireLigne (n)
            Case Is > ValeurMini
                If Data < ValeurMaxi Then ExtraireLigne (n)
            Case Else
                Range("F" & n).Interior.ColorIndex = 0
        End Select
    Next n
End Sub
Private Sub ExtraireLigne(LigneNum As Double)
    'copier la ligne
    Range("A" & LigneNum & ":G" & LigneNum).Select
    Selection.Copy
    '----- destination de la ligne
    'nombre de ligne de la table de destination
    If Range("O2").Value = "" Then
        LigneNBDest = 2
    Else
        LigneNBDest = Range("O1").End(xlDown).Row + 1
    End If
    '
    Range("O" & LigneNBDest).Select
    'coller la ligne
    ActiveSheet.Paste
End Sub

@+JP

15/02/2022, 10h30
flooki

j'ai essaye de faire ça mais mon code d'extraction est incomplet , il m'affiche pas les lignes qui correspond dans la nouvelle feuille
15/02/2022, 10h57
mjpmjp

bonjour,
affiche ton code

@+JP
15/02/2022, 11h04
flooki

1 pièce(s) jointe(s)

rebonjour ,
merci bcp pour votre aide , ton code ca me va vraiment bien , la maintenant je vais essaye avant d'extraire les données dans un nouvelle tableau , le code affiche une fenetre de controle qui contient les largeur et selectioner quelle ligne je veux extraire en cochant la largeur . Pièce jointe 613713
à la palce de numéro j'aurais les largeur qui correspond au hauteur choisis et aprés extraire la ligne qui correspond a la largeur cocher . si vous avez une idée comment faire ca .
merci en avance
15/02/2022, 11h07
flooki

est ce que vous pouvez me mettre le fichier en piece jointe svp .
merci
15/02/2022, 11h14
mjpmjp

bonjour,
si j'ai bien compris , tu ne veut pas extraire toutes les lignes , mais choisir dans ces lignes celles que tu veut extraire.

dans le code qui écrit les lignes , tu modifies la destination :mouarf:

en fait , la nouvelle destination est un contrôle liste avec les options de sélection !!!

et de là tu écris dans la table

@+JP
15/02/2022, 11h21
flooki

exactement , si ta une idée comment le faire ca va m'aider énormément .
mercii bcp monsieur pour votre aide

3 pièce(s) jointe(s)

bonjour,
je doit me replonger dans le codage VBA car j'avais un peu décroché :D

mais bon ... voila en concret ce que je t'ais dit :

Pièce jointe 613725

pour configurer la ListBox voila les propriétés :

Pièce jointe 613726

pour le VBA , voila les déclarations avec 2 nouvelles constantes , celles des colonnes Hauteur et Largeur

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Private LigneNB As Double
Private ValeurOrigin As Integer
Private ValeurMaxi As Integer
Private ValeurMini As Integer
Private ValeurEcart As Integer
Private Data As Integer
Const ColHauteurStr As String = "F"
Const ColLargeurStr As String = "G"
 
'-------------------------- table destination
Private LigneNBDest As Double

pour la recherche , avec un changement ligne 10 / 11

Code:

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
 
Private Sub CommandButton2_Click()
    'nombre de ligne de la table
    LigneNB = Range("F1").End(xlDown).Row
    'les écarts de valeur
    ValeurOrigin = Range("J4").Value
    ValeurEcart = Range("K4").Value
    ValeurMaxi = ValeurOrigin + ValeurEcart
    ValeurMini = ValeurOrigin - ValeurEcart
    'efface la liste avec option
    ListBox1.Clear
    'efface les couleurs
    Range("J4").Select
    Selection.Copy
    Range("F2:F" & LigneNB).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("J4").Select
    'boucle
    For n = 2 To LigneNB
        Data = Range("F" & n).Value
        Select Case Data
            Case Is = ValeurOrigin
                ExtraireLigne (n)
            Case Is = ValeurMaxi
                ExtraireLigne (n)
            Case Is = ValeurMini
                ExtraireLigne (n)
            Case Is > ValeurMini
                If Data < ValeurMaxi Then ExtraireLigne (n)
            Case Else
                Range("F" & n).Interior.ColorIndex = 0
        End Select
    Next n
End Sub

pour l'écriture dans la liste

Code:

1
2
3
4
5
6
7
8
9
10
11
 
 
Private Sub ExtraireLigne(LigneNum As Double)
    NBligne = ListBox1.ListCount
    ListBox1.AddItem " "
    ListBox1.List(NBligne, 0) = Range(ColHauteurStr & LigneNum).Value
    ListBox1.List(NBligne, 1) = Range(ColLargeurStr & LigneNum).Value
    'ListBox1.List(NBligne, 0) = Application.WorksheetFunction.RoundUp(Range(ColHauteurStr & LigneNum).Value, 0)
    'ListBox1.List(NBligne, 1) = Application.WorksheetFunction.RoundUp(Range(ColLargeurStr & LigneNum).Value, 0)
    ListBox1.List(NBligne, 2) = LigneNum
End Sub

si on rend valide les lignes 8 et 9 voila le résultat

Pièce jointe 613729

15/02/2022, 13h20
flooki

pouvez vous m'envoyer le fichiers en piece jointe , car j'ai pas pu intégrer ces codes proprement
merci

2 pièce(s) jointe(s)

bonjour,

pour finir , les donées de la ListBox sont arrondies à sup et j'ai sélectionné 2 lignes , dont la dernière pour être sur que la boucle soit complète :lol:

Pièce jointe 613734

voila le code qui copie uniquement les lignes sélected de la ListBox

bouton copier les lignes

Code:

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
 
 
Private Sub CommandButton3_Click()
    'boucle
    For n = 1 To ListBox1.ListCount - 1
        '----- destination de la ligne
        'nombre de ligne de la table de destination
        If Range("O2").Value = "" Then
            LigneNBDest = 2
        Else
            LigneNBDest = Range("O1").End(xlDown).Row + 1
        End If
        '----- analyse de la ListBox
        If ListBox1.Selected(n) = True Then
            'numéro de ligne écrit dans la listBox
            LigneNum = ListBox1.List(n, 2)
            'copier la ligne
            Range("A" & LigneNum & ":G" & LigneNum).Select
            Selection.Copy
            'ligne de destination
            Range("O" & LigneNBDest).Select
            'coller la ligne
            ActiveSheet.Paste
        End If
    Next n
End Sub

:coucou: @+ JP

16/02/2022, 10h45
flooki

rebonjour
je voudrais vous remercier pour votre aide , en effet j'ai rencontré un problème avec le code , quand je selectionne plusieurs ligne , la premier ligne de la listebox ne s'affiche pas dans le tableaux , et j'aimerais bien ajouté un boutton pour réanitialiser le lignes selectionner et les supprimer pour copier d'autre ligne .
merci en avance
16/02/2022, 10h49
mjpmjp

bonjour,

je pense que ce doit être un problème d'index style 1 à la place de 0 , je regarde :D

(pour le bouton également)

@+JP
16/02/2022, 10h52
flooki

c'est bon j'ai régler le pbl de l'affichage de la premiere selection de la listebox . je suis entrain d'ajouter une commande pour supprimer les lignes déja copier dans le tableaux
16/02/2022, 11h34
flooki

est ce que vous avez une idée comment supprimer les lignes copier . afin de copier des nouvelles lignes

bonjour,

si tu veut dire supprimer dans le tableau , tu as le numéro de la ligne dans la colonne 3 de la ListBox : ListBox1.List(1,2) ici , le 1 c'est la ligne et 2 c'est la colonne (0,1,2)

en fait ce que je dis là , c'est pour le tableau d'origine !!! :aie: mais pas pour celui de destination :weird:

tu as fait quoi pour l'erreur ?

ok voila le code corrigé (ligne 4)

Code:

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
 
Private Sub CommandButton3_Click()
    'boucle
    For n = 0 To ListBox1.ListCount - 1
        '----- destination de la ligne
        'nombre de ligne de la table de destination
        If Range("O2").Value = "" Then
            LigneNBDest = 2
        Else
            LigneNBDest = Range("O1").End(xlDown).Row + 1
        End If
        '----- analyse de la ListBox
        If ListBox1.Selected(n) = True Then
            'numéro de ligne écrit dans la listBox
            LigneNum = ListBox1.List(n, 2)
            'copier la ligne
            Range("A" & LigneNum & ":G" & LigneNum).Select
            Selection.Copy
            'ligne de destination
            Range("O" & LigneNBDest).Select
            'coller la ligne
            ActiveSheet.Paste
        End If
    Next n
End Sub

@+JP

16/02/2022, 12h22
flooki

pour l'erreur c'était exactement ce que tu as dit , une boucle qui commence par 1 à la place de 0

2 pièce(s) jointe(s)

bonjour,

oups , :mouarf: , j'ai oublié de poster la suite ...

Pièce jointe 613865

les déclarations

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Private LigneNB As Double
Private ValeurOrigin As Integer
Private ValeurMaxi As Integer
Private ValeurMini As Integer
Private ValeurEcart As Integer
Private Data As Integer
Const ColHauteurStr As String = "F"
Const ColLargeurStr As String = "G"
Const ColHauteurDStr As String = "T"
Const ColLargeurDStr As String = "U"
'-------------------------- table destination
Private LigneNBDest As Double

le bouton extraire la liste de droite

Code:

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
 
 
Private Sub CmdExtraireDroite_Click()
    If Range("T2").Value = "" Then Exit Sub
    'nombre de ligne de la table
    LigneNB = Range("T1").End(xlDown).Row
    'les écarts de valeur
    ValeurOrigin = Range("J4").Value
    ValeurEcart = Range("K4").Value
    ValeurMaxi = ValeurOrigin + ValeurEcart
    ValeurMini = ValeurOrigin - ValeurEcart
    'efface la liste avec option
    ListBox2.Clear
    'boucle
    For n = 2 To LigneNB
        Data = Range("T" & n).Value
        Select Case Data
            Case Is = ValeurOrigin
                ExtraireLigneDroite (n)
            Case Is = ValeurMaxi
                ExtraireLigneDroite (n)
            Case Is = ValeurMini
                ExtraireLigneDroite (n)
            Case Is > ValeurMini
                If Data < ValeurMaxi Then ExtraireLigneDroite (n)
            Case Else
                '
        End Select
    Next n
End Sub

la SUB pour écrire dans la ListBox 2

Code:

1
2
3
4
5
6
7
8
9
10
 
Private Sub ExtraireLigneDroite(LigneNum As Double)
    NBligne = ListBox2.ListCount
    ListBox2.AddItem " "
    ListBox2.List(NBligne, 0) = Range(ColHauteurDStr & LigneNum).Value
    ListBox2.List(NBligne, 1) = Range(ColLargeurDStr & LigneNum).Value
    ListBox2.List(NBligne, 0) = Application.WorksheetFunction.RoundUp(Range(ColHauteurDStr & LigneNum).Value, 0)
    ListBox2.List(NBligne, 1) = Application.WorksheetFunction.RoundUp(Range(ColLargeurDStr & LigneNum).Value, 0)
    ListBox2.List(NBligne, 2) = LigneNum
End Sub

le bouton supprimer

Code:

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
 
 
Private Sub CmdSupprimer_Click()
    '----- destination
    'nombre de ligne de la table de destination
    If Range("O2").Value = "" Then
        LigneNBDest = 2
    Else
        LigneNBDest = Range("O1").End(xlDown).Row
    End If
    'boucle
    For n = 0 To ListBox2.ListCount - 1
        '----- analyse de la ListBox
        If ListBox2.Selected(n) = True Then
            'numéro de ligne écrit dans la listBox
            LigneNum = ListBox2.List(n, 2)
            'effacer la ligne
            Range("O" & LigneNum & ":U" & LigneNum).Select
            Selection.ClearContents
        End If
    Next n
    'supprime les ligne vide (trier AZ)
    Range("O2:U" & LigneNBDest).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("O2:O22") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("O2:U" & LigneNBDest)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

:coucou: @+JP

17/02/2022, 11h10
flooki

merci bcp pour votre aider , j'aimerais bien savoire est ce qu'il y a une façon de faire une copie de cette feuille dans une autre dans le méme classeurs touts en conservant la macro et les bouttons , seulement pour appliquer le méme traitement sur d'autre donné
17/02/2022, 11h22
mjpmjp

bonjour,

pour répondre à ta question ,
tu fait un click droit sur le nom de l'onglet et tu choisi "déplacer/copier" et tu coches la case "copier"

tu as le mécanisme principal , on vat dire que c'est un prototype :D

et bien sur tu peut l'adapter à plusieurs situations

dans le principe il y a une "source/origine/départ" et une "cible/arrivé"
il faut donc rendre "anonyme/universelle" chacune des partie de programme
on le fait avec des "variables" ou des "object" qui vont remplacer les "nom unique" actuellement utilisé

@+JP
17/02/2022, 11h35
flooki

1 pièce(s) jointe(s)

rebonjour,
j'ai un peux mal a comprendre comment le faire , en effet sur ce fichier Pièce jointe 613931 je veux diviser le tableaux en deux " un tableaux qui contient les donnée faible de colonne A et deuxième des donnée élevé de colonne A " et les mettre dans deux feuille , et appliquer le mémé macro sur les deux feuille .
17/02/2022, 11h40
flooki

rebonjour
j'ai arriver le faire avec la fonction copie , au première tant j'avais pas le droit le faire car je pouvez pas le sélectionner .
merci