[XL-2003] Créer des tableaux par extraction de données sur un tableau principal

[mandrake57]

Bonsoir à tous,

Pour mon travail je cherche à automatiser le traitement de résultats. C'est pourquoi j'aimerais pouvoir extraire des données d'un tableau principal en fonction des en-têtes des colonnes et créer des tableaux en fonction de ses en-têtes.

Je vous joins le fichier test:

- dans la feuil1 on trouve le tableau principal et dans la feuil3 on trouve les tableaux de la façon ouù j'aimerais les retrouver.

- les en-têtes sont composées d'un élément chimique et d'une longueur d'onde et j'aimerais à chaque fois réunir un même élément dans un même tableau et après créer 3 colonne, une où on aurait le calcul auto de la moyenne des valeurs, une où je pourrais entrer la valeur théorique, une qui afficherait la différence des deux...

Je me dois de préciser que le nb de colonnes pour un même élément est variable, et qu'ils ne sont pas forcément dans l'ordre.

Voici un début de code (il n'est pas optimisé je pense), si quelqu'un voit comment faire ce serait super (je suis pas contre une optimisation de mon code).

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
Sub tri_elements()
With Sheets("Sheet1") 'se place dans la page 1
    nb_ligne = Range("A65536").End(xlUp).Row 'récupère le numéro de la dernière ligne
    nb_colonne = Range("IV1").End(xlToLeft).Column ' récupère le numéro de la dernière colonne
    element_precedent = "" ' initialise le nom de l'élément
    For col = 3 To nb_colonne Step 1 ' boucle sur l'ensemble des colonnes (de 2 en 2)
        element = Mid(Cells(1, col), 1, 2) ' récupère le nom de l'élément actuel
        If element <> element_precedent Then ' compare l'élément actuel et le précédent
            Range(Cells(1, 1), Cells(nb_ligne, 1)).Copy ' s'ils sont différents copie la liste des échantillons
            Sheets("Sheet3").Select ' va dans la feuille 3
            nouvelle_ligne = Range("A65536").End(xlUp).Row ' cherche la nouvelle ligne pour démarrer un nouveau tableau
            If nouvelle_ligne = 1 Then nouvelle_ligne = -1 ' modifie le numéro de ligne si c'est le début du tri
                Range("A" & nouvelle_ligne + 2).Select
                ActiveSheet.Paste ' colle la liste des échantillons
                Range("B" & nouvelle_ligne + 2).Select ' se place pour le prochain collage
                element_precedent = element ' note le nom de l'élément pour le prochain test
        End If
        Sheets("Sheet1").Select ' sélectionne la feuille 1
        Range(Cells(1, col), Cells(nb_ligne, col)).Copy ' copie les infos de l'élément
        Sheets("Sheet3").Select ' sélectionne la feuille 3
        ActiveSheet.Paste ' colle les infos de l'élément
        Cells(nouvelle_ligne + 2, Range("IV" & nouvelle_ligne + 2).End(xlToLeft).Column + 1).Select ' se place pour le prochain collage
        Sheets("Sheet1").Select ' sélectionne la feuille 1
    Next
End With
End Sub

Merci beaucoup pour votre aide!

[mandrake57]

Bonsoir,

J'ai un peu avancé sur ma question, j'arrive à faire un tri en fonction des en-têtes mais je bute sur l'importation des données sur l'autre feuille.

Voici mon code:

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
Sub tri_elems()
 
Dim col As Byte, coll As Byte
 
With Sheets("Sheet1") 'se place dans la page 1
    nblig = .Range("A" & .Rows.Count).End(xlUp).Row 'définition de la valeur de la dernière ligne
    nbcol = .Range("IV1").End(xlToLeft).Column ' récupère le numéro de la dernière colonne
    For col = 3 To nbcol Step 1
        elemrech = Mid(Cells(1, col), 1, 2) ' récupère le nom de l'élément actuel
        For coll = 3 To nbcol Step 1
            If Mid(Cells(1, coll), 1, 2) <> elemrech Then
                Columns(coll).EntireColumn.Hidden = True
            End If
        Next
        Set Rng = .Cells(1, 1).CurrentRegion 'définition des donnée à transférer sur la base de la troisième colonne (demandeur)
            Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 0, 1).SpecialCells(xlCellTypeVisible)
 
 
With Sheets("Sheet3")
    lig = .Range("A" & .Rows.Count).End(xlUp).Row 'définition de la valeur de la dernière ligne
    If lig > 1 Then
        lig = lig + 2
    End If
    For Each R In Rng
        If Not R.Row = 3 Then 'application des données de la feuille "Base" sur la feuille "Bulletin"
            .Range("A" & lig) = R.Offset(0, 0)
        End If
        lig = lig + 1
    Next R
End With
        Columns("A:IV").EntireColumn.Hidden = False
    Next
End With
End Sub

Avez-vous une idée pour la suite de ma question?

[Sclarckone]

J'ai un peu de mal à comprendre ce que tu veux faire dans la deuxième partie de ton code:

Code :

1
2
3
4
5
6
    For Each R In Rng
        If Not R.Row = 3 Then 'application des données de la feuille "Base" sur la feuille "Bulletin"
            .Range("A" & lig) = R.Offset(0, 0)
        End If
        lig = lig + 1
    Next R

Tu veux copier toutes les lignes non masquées de 'Sheet1'?

Ceci dit, même si c'est peut-être la logique d'Excel (ça ressemble au fonctionnement des filtres), je n'aime pas trop la stratégie consistant à masquer/démasquer les lignes pour faire les sélections.
On pourrait imaginer une solution avec des tableaux d'adresses de plage, par exemple.

[mandrake57]

merci pour ta réponse.

je ne connais pas la méthode des tableaux avec adresse de plage.

saurais tu me montrer?

merci!

[Sclarckone]

Tu n'as pas répondu à ma première question:

Tu veux copier toutes les lignes non masquées de 'Sheet1'?

J'en déduis donc que la réponse est oui...


Pour revenir à ce que je disais sur les tableaux contenant des adresses de plages de cellules; à la réflexion ça n'a pas non plus en grand intérêt en fait...
Car c'est sortir de la grosse artillerie pour pas grand chose.

Au final, le plus simple dans ton cas c'est de faire la copie vers la deuxième feuille directement (plutôt que de passer par une sélection).

Donc dans ton premier bloc de code, juste après avoir testé si ta cellule contient l'élément recherché, copie directement la ligne si le résultat est positif. En pratique:

Code :

1
2
3
4
        For coll = 3 To nbcol Step 1
            If Mid(Cells(1, coll), 1, 2) = elemrech Then
                Cells(1, coll).EntireRow.Copy (ThisWorkbook.Sheets("Sheet3").Range("A" & .Rows.Count).End(xlUp))
        Next coll