Microsoft 365 extraction de données d'un tableau

Bob 31

XLDnaute Junior
Bonjour

J'ai un tableau avec des macros et une extraction par mois et je souhaiterai que l'extraction se fasse par mois comme c'est le cas mais en classant le résultat comme pour l'exemple que j'ai inscrit sur l'onglet "JANVIER"
Je souhaiterai que sur la première colonnes soit copier les matricules (autant de ligne que de besoin 21 je penses), sur la deuxième colonnes les libellés en fluo (.HBA .TH etc...) et sur la troisième colonne le résultat pour chaque matricules et libellés.

En vous remerciant pour votre aide

Cordialement
 
Solution
Bonjour Bob et bienvenu, bonjour le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

VB:
Private Sub btnExtraction_click()
Dim OA As Worksheet 'déclare la variable OA (Onglet Année)
Dim TET(1 To 21) As String 'déclare le tableau de 21 variables TET (Tableau des En-Têtes)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim OM As Worksheet 'déclare la variable OM (Onglet Mois)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Application.ScreenUpdating = False 'masque les...

Robert

XLDnaute Barbatruc
Bonjour Bob et bienvenu, bonjour le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

VB:
Private Sub btnExtraction_click()
Dim OA As Worksheet 'déclare la variable OA (Onglet Année)
Dim TET(1 To 21) As String 'déclare le tableau de 21 variables TET (Tableau des En-Têtes)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim OM As Worksheet 'déclare la variable OM (Onglet Mois)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Application.ScreenUpdating = False 'masque les raffraîchissements d'écran
Set OA = Worksheets("ANNEE") 'définit l'onglet OA
TET(1) = ".HBA" 'définit l'en-tête TET(1)
TET(2) = ".TH" 'définit l'en-tête TET(2)
TET(3) = ".TTE" 'définit l'en-tête TET(3)
TET(4) = "BCOU" 'définit l'en-tête TET(4)
TET(5) = "BAMP" 'définit l'en-tête TET(5)
TET(6) = ".HCO" 'définit l'en-tête TET(6)
TET(7) = ".HS1" 'définit l'en-tête TET(7)
TET(8) = ".HS2" 'définit l'en-tête TET(8)
TET(9) = "BC" 'définit l'en-tête TET(9)
TET(10) = "BTDN" 'définit l'en-tête TET(10)
TET(11) = "BSD" 'définit l'en-tête TET(11)
TET(12) = "BSD2" 'définit l'en-tête TET(12)
TET(13) = "BJF" 'définit l'en-tête TET(13)
TET(14) = "BJF2" 'définit l'en-tête TET(14)
TET(15) = "BRE" 'définit l'en-tête TET(15)
TET(16) = "BAST" 'définit l'en-tête TET(16)
TET(17) = "BH24" 'définit l'en-tête TET(17)
TET(18) = "BPE" 'définit l'en-tête TET(18)
TET(19) = "B13" 'définit l'en-tête TET(19)
TET(20) = ".ACO" 'définit l'en-tête TET(20)
TET(21) = ".C.C" 'définit l'en-tête TET(21)
TV = OA.Range("A1").CurrentRegion 'définit le tableau des valeurss TV
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 1) = Me.ComboRegion.Value Then 'condition 1 : si la donnée ligne I colonne 1 de TV est égale à la valeur de la combobox [ComboRegion]
        On Error Resume Next 'gestion des erreurs (e cas d'erreur passe à la ligne suivante)
        Set OM = Worksheets(Me.ComboRegion.Value) 'définit l'onglet du mois OM (génère une erreur si cet onglet n'existe pas)
        If Err <> 0 Then 'condition 2 : si une erreur a été générée
            Err.Clear 'supprime l'erreur
            Worksheets.Add before:=Worksheets("ANNEE") 'ajoute une onglet vierge avant l'onglet "ANNEE"
            Set OM = ActiveSheet 'définit l'onglet OM
            OM.Name = Me.ComboRegion.Value 'nomme l'onglet OM
        End If 'fin de la condition 2
        For J = 1 To 21 'boucle 2 : sur les 21 en-têtes J
            For L = 6 To UBound(TV(I, 2)) 'boucle 3 : sur toutes les colonne L du tableau des valeurs (en partant de la 6ème)
                If TV(1, L) = TET(J) Then 'condition3 : si la donnée ligne 1 colonne L de TV est égale à l'en-tête TET(J)
                    K = K + 1 'incrémente K
                    ReDim Preserve TL(1 To 3, 1 To K) 'redimensionne le tableau des lignes TL(3 lignes, K colonnes)
                    TL(1, K) = TV(I, 3) 'récupère dans la ligne 1 de TL la donnée en colonne 3 de TV
                    TL(2, K) = TET(J) 'récupère dans la ligne 2 de TL l'en-tête TET(J)
                    TL(3, K) = OA.Cells(I, OA.Rows(1).Find(TET(J), , xlValues, xlWhole).Column).Value 'récupère dans la ligne 3 de TL la valeur de la cellule ligne I, colonne = recheche exacte de TET(J) dans la ligne 1 de l'onglet OA
                    Exit For 'sort de la boucle 3
                End If 'fin de la condition 3
            Next L 'prochaine colonne de la boucle 3
        Next J 'prochaine en-tête de la boucle 2
    End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle 1
Unload Me 'vide et ferme l'UserForm en cours
With OM 'prend en compte l'ongelt OM
    .Cells.ClearContents 'efface toutes les cellules
    .Range("A1").Value = "MATRICULE" 'écrit en A1
    .Range("C1").Value = "NOMBRE" 'écrit en C1
    'si K est supérieure à zéro, renvoie le tableau TL transposé dans A2 redimensionnée
    If K > 0 Then .Range("A2").Resize(K, 3).Value = Application.Transpose(TL)
    .Columns(3).NumberFormat = "0.00" 'format de la colonne C de l'onglet OM
    .Activate 'active l'onglet
End With 'fin de la prise en compte de l'onglet OM
Application.ScreenUpdating = True    'affiche les raffraîchissements d'écran
MsgBox "Données traitées !" 'message
End Sub

Le fichier :
 

Pièces jointes

  • Bob_ED_v01.xlsm
    460.6 KB · Affichages: 25

Bob 31

XLDnaute Junior
Bonsoir Robert

Vraiment trop fort
Vous m'avez bien aidé, je n'ai pas du tout votre niveau et maitrise
Je l'essaye et le met en place
Je me permettrais de revenir vers vous pour précision
Un grand merci pour votre aide
A très bientôt
Cordialement

Bob
 

Bob 31

XLDnaute Junior
Bonsoir Robert
L'extraction fonctionne bien mais j'aimerai l'améliorer au vu de l'utilisation :
Sur l'extraction je souhaiterai supprimer de la première ligne le libellé " matricule et nombre" et débuter directement par
AF.HBA
151,67​

Je ne sais si c'est possible mais je souhaiterai également ne pas extraire les matricules lignes et les résultats des matricules nommés : #REF!

Pour les résultats des nombres est il possible de déterminer le nombre de décimales après la virgule dans la programmation suivant les 21 éléments :

.HBA
.TH
.TTE
BCOU
BAMP
.HCO
.HS1
.HS2
BC
BTDN
BSD
BSD2
BJF
BJF2
BRE
BAST
BH24
BPE
B13
.ACO
.C.C

Si un jour je veux supprimer la ligne et le résultat de : TET(19) = "B13" 'définit l'en-tête TET(19) est ce qu'il faut que je supprime cela dans la programmation ainsi que de renommer les ligne suivantes (19) puis (20) et remplacer For J = 1 To 21 'boucle 2 : sur les 21 en-têtes J
par : For J = 1 To 20 'boucle 2 : sur les 20 en-têtes J

Merci encore et bonne soirée
A très bientôt
Bob 31
 

Bob 31

XLDnaute Junior
Bonjour ci joint un tableau ou Robert m'a mis au point la macro d'extraction

L'extraction fonctionne bien mais j'aimerai amener des modifications au vu de l'utilisation :
Je souhaiterai que les résultats de l'extraction puissent être mis à jour et garder le lien avec les données de l'onglet année.

Sur l'extraction je souhaiterai supprimer de la première ligne le libellé " matricule et nombre" et débuter directement par
AF.HBA151,67

Je souhaiterai également ne pas extraire les matricules lignes et les résultats des matricules nommés : #REF! et ne pas extraire le matricule si l'ensemble des libellés donne comme résultat du nombre 0 ou non renseigné (vide)

Pour les résultats des nombres est il possible de déterminer le nombre de décimales après la virgule dans la programmation suivant les 21 éléments :

.HBA
.TH
.TTE
BCOU
BAMP
.HCO
.HS1
.HS2
BC
BTDN
BSD
BSD2
BJF
BJF2
BRE
BAST
BH24
BPE
B13
.ACO
.C.C

Merci encore et bonne journée
A très bientôt
Bob 31
 

Discussions similaires

Réponses
0
Affichages
431
Réponses
0
Affichages
331

Statistiques des forums

Discussions
299 956
Messages
1 980 368
Membres
207 067
dernier inscrit
Miks57450