Réduction colonne avec transfert valeur numérique et entête tableau

[cathodique]

Bonjour,

Sur l'une de mes feuilles, je récupère un tableau de données via une userform. Suivant les sélections effectuées le nombre de lignes et de colonnes est variable.

Afin de préparer un rapport, je dois synthétiser ce tableau en réduisant le nombre de colonnes.

Pour cela, je voudrais concaténer l’entête de colonne du tableau avec la valeur numérique se trouvant dans la même colonne, et sur la même ligne que la valeur numérique, la mettre en colonne "observation" avec un retour à la ligne.

Puis supprimer les colonnes à partir de: col4 à dernière colonne - 1.

Sur le fichier joint, j'ai mis une image du résultat à obtenir.

En vous remerciant.

Cordialement,

 

[Robert]

Re : Réduction colonne avec transfert valeur numérique et entête tableau

Bonjour Cathodique, bonjour le forum,

Peut-être comme ça :

Sub Macro1()
Dim oi As Object 'déclare la variable oi (Onglet Initial)
Dim od As Object 'déclare la variable od (Onglet Destination)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim dc As Integer 'déclare la variable dc (Dernière Colonne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)

Set oi = Sheets("Initial") 'définit l'onglet initial oi
Set od = Sheets("Feuil3") 'définit l'onglet destination od
dl = oi.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A) de l'onglet initial
dc = oi.Cells(7, Application.Columns.Count).End(xlToLeft).Column 'définit la dernière colonne éditée dl de la ligne 7 de l'onglet initial
Set pl = oi.Range(oi.Cells(9, 4), oi.Cells(dl, dc - 2)) 'définit la plage des valeurs pl
oi.Range("A7:C" & dl).Copy od.Range("A7") 'copie les trois premières colonnes
oi.Range(oi.Cells(7, dc), oi.Cells(dl, dc)).Copy od.Range("D7") 'copie la dernière colonne
For Each cel In pl 'boucle sur toutesles cellules cel de la plage des valeur pl
    If cel.Value <> "" Then 'condition : si la cellule n'est pas vide
        'récupère le texte coorespondant à l'observation, le paramètre outil et la valeur et la colle dans la colonne D
        od.Cells(cel.Row, 4).Value = oi.Cells(cel.Row, dc).Value & Chr(10) & oi.Cells(7, cel.Column).Value & "=" & cel.Value
    End If 'fin de la condition
Next cel 'prochaine cellule de la boucle
End Sub

 

[cathodique]

Re : Réduction colonne avec transfert valeur numérique et entête tableau

Bonjour Robert,

Je te remercie beaucoup pour ton code et pour la célérité de ta réponse. Je suis impardonnable, je t'ai induit en erreur avec mon fichier. J'y ai rajouté les feuilles 2 et 3; la 2 (initial), c'est pour remettre les données en la feuille1 pour effectuer un nouveau test et la feuille 3 c'est le résultat à obtenir mais en feuille 1. c'est à dire que la macro doit agir sur la feuille1, il n'y a pas de feuille de destination.

Toutes mes excuses. Merci beaucoup.

je joins le fichier avec une seule feuille.

Cordialement,

 

[Robert]

Re : Réduction colonne avec transfert valeur numérique et entête tableau

Bonjour Cathodique, bonjour le forum,

le code corrigé :

Sub Macro1()
Dim o As Object 'déclare la variable o (Onglet)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim dc As Integer 'déclare la variable dc (Dernière Colonne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim t As String 'déclare la variable t (Texte)

Set o = Sheets("Feuil1") 'définit l'onglet initial o
dl = o.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A) de l'onglet initial
dc = o.Cells(7, Application.Columns.Count).End(xlToLeft).Column 'définit la dernière colonne éditée dl de la ligne 7 de l'onglet initial
Set pl = o.Range(o.Cells(9, 4), o.Cells(dl, dc - 2)) 'définit la plage des valeurs pl
For Each cel In pl 'boucle sur toutesles cellules cel de la plage des valeur pl
    If cel.Value <> "" Then 'condition : si la cellule n'est pas vide
        'définit la variable t,récupère le texte correspondant à l'observation, le paramètre outil et la valeur et la colle dans la colonne D
        t = o.Cells(cel.Row, dc).Value & Chr(10) & o.Cells(7, cel.Column).Value & "=" & cel.Value
        o.Cells(cel.Row, dc).Value = t 'place le texte t dans la dernière colonne
    End If 'fin de la condition
Next cel 'prochaine cellule de la boucle
o.Range(o.Cells(7, 4), o.Cells(7, dc - 2)).EntireColumn.Delete 'supprime les colonnes inutiles
End Sub

 

[cathodique]

[Résolu] : Réduction colonne avec transfert valeur numérique et entête tableau

Re Robert,

Je te remercie beaucoup, ton code est parfait. C'est ce que je voulais obtenir.

Mille mercis.

Cordialement,