XL 2016 excel VBA

stephanie94

XLDnaute Nouveau
Bonjour à tous,

j'ai un fichier tiré d'une extraction avec 6 ligne les unes sous les autres

Mon extraction fait plus de 67000 lignes. est ce qu'il existerait une macro qui me permettrait de faire une presentation "transposé" comme je l'ai fait dans l'onglet 2 afin d'obtenir un tableau exploitable en terme de filtres, TCD...

Je ne connais pas la VBA mais je sais que pour le coup cela va me sauver la vie

Merci d'avance à tous
 

Pièces jointes

  • AIT test.xlsx
    10.7 KB · Affichages: 11

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour le fil, bonjour le forum,

Une proposition avec le code ci-dessous :

VB:
Option Explicit 'oblige à déclarer toutes les variables

Sub Macro1()
Dim OE As Worksheet 'déclare la variable OE (Onglet de l'Extraction)
Dim OP As Worksheet 'déclare la variable OP (Onglet de la Présentation)
Dim TV As Variant 'déclare la variable TV (Tableau des valeurs)
Dim TL() As Variant 'déclare la variable TL (tableau des Lignes
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variable K (incrément)

Set OE = Worksheets("Feuil2") 'définit l'onglet OE (à adapter à ton cas)
Set OP = Worksheets("presentation voulue") 'définit l'onglet OP (à adapter à ton cas)
TV = OE.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 1 To UBound(TV, 1) 'boucle sur toutes les lignes i du tableau des valeurs TV
    Select Case TV(I, 1) 'agit en fonction de la donnée ligne I colonne 1 de TV
        Case "TITLE" 'cas "TITLE"
            K = K + 1 'incrémente K
            ReDim Preserve TL(1 To 7, 1 To K) 'redimensionne le tableau des lignes TL (7 lignes, K colonnes)
            TL(1, K) = TV(I, 2) 'récupère dans la ligne 1 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "AUTHOR NAMES" 'cas "AUTHOR NAMES"
            TL(2, K) = TV(I, 2) 'récupère dans la ligne 2 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "SOURCE" 'cas "SOURCE"
            TL(3, K) = TV(I, 2) 'récupère dans la ligne 3 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "PUBLICATION YEAR" 'cas "PUBLICATION YEAR"
            TL(4, K) = TV(I, 2) 'récupère dans la ligne 4 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "VOLUME" 'cas "VOLUME"
            TL(5, K) = TV(I, 2) 'récupère dans la ligne 5 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "ISSUE" 'cas "ISSUE"
            TL(6, K) = TV(I, 2) 'récupère dans la ligne 6 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "DOI" 'cas "DOI"
            TL(7, K) = TV(I, 2) 'récupère dans la ligne 7 de TL la donnée en colonne 2 de TV (=> Transposition)
    End Select 'fin de l'action en fonction de la donnée ligne I colonne 1 de TV
Next I 'prochaine ligne de la boucle
OP.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes doonnées (sauf la ligne 1)
OP.Range("A2").Resize(K, 7).Value = Application.Transpose(TL) 'renvoie dans A2 redimensionnée le tableau TL transposé
End Sub

Attention ! comme dans ton exemple, quand il y a plusieurs auteurs (dans plusieurs colonnes) il ne prend que le premier...
 

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour le fil, bonjour le forum,

Le code modifié pour récupérer tous les auteurs :

VB:
Sub Macro1()
Dim OE As Worksheet 'déclare la variable OE (Onglet de l'Extraction)
Dim OP As Worksheet 'déclare la variable OP (Onglet de la Présentation)
Dim TV As Variant 'déclare la variable TV (Tableau des valeurs)
Dim TL() As Variant 'déclare la variable TL (tableau des Lignes
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)

Set OE = Worksheets("Feuil2") 'définit l'onglet OE (à adapter à ton cas)
Set OP = Worksheets("presentation voulue") 'définit l'onglet OP (à adapter à ton cas)
TV = OE.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 1 To UBound(TV, 1) 'boucle sur toutes les lignes i du tableau des valeurs TV
    Select Case TV(I, 1) 'agit en fonction de la donnée ligne I colonne 1 de TV
        Case "TITLE" 'cas "TITLE"
            K = K + 1 'incrémente K
            ReDim Preserve TL(1 To 7, 1 To K) 'redimensionne le tableau des lignes TL (7 lignes, K colonnes)
            TL(1, K) = TV(I, 2) 'récupère dans la ligne 1 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "AUTHOR NAMES" 'cas "AUTHOR NAMES"
            For J = 2 To UBound(TV, 2) 'boucle sur toutes les colonnes J du tableau des valeurs TV
                If TL(2, K) = "" Then 'condition : si TL(2,K) est vide
                    TL(2, K) = TV(I, 2) 'recupère le premier auteur
                Else 'sinon
                    'si il existe d'autres auteurs récupère les autres auteurs séparés par une virgule
                    If TV(I, J) <> "" Then TL(2, K) = TL(2, K) & ", " & TV(I, J)
                End If
            Next J
        Case "SOURCE" 'cas "SOURCE"
            TL(3, K) = TV(I, 2) 'récupère dans la ligne 3 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "PUBLICATION YEAR" 'cas "PUBLICATION YEAR"
            TL(4, K) = TV(I, 2) 'récupère dans la ligne 4 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "VOLUME" 'cas "VOLUME"
            TL(5, K) = TV(I, 2) 'récupère dans la ligne 5 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "ISSUE" 'cas "ISSUE"
            TL(6, K) = TV(I, 2) 'récupère dans la ligne 6 de TL la donnée en colonne 2 de TV (=> Transposition)
        Case "DOI" 'cas "DOI"
            TL(7, K) = TV(I, 2) 'récupère dans la ligne 7 de TL la donnée en colonne 2 de TV (=> Transposition)
    End Select 'fin de l'action en fonction de la donnée ligne I colonne 1 de TV
Next I 'prochaine ligne de la boucle
OP.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes doonnées (sauf la ligne 1)
OP.Range("A2").Resize(K, 7).Value = Application.Transpose(TL) 'renvoie dans A2 redimensionnée le tableau TL transposé
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof