Copier Transposer une ligne d'une certaine plage de colonnes

Bonjour,

je dois optimiser un fichier, et je sollicite votre aide car je suis bloqué.

Ce fichier, qui est composé de deux pages, fonctionne comme suit :

• dans la feuille "Infos", il faut sélectionner une ligne puis cliquer sur le bouton
• les infos de la ligne sélectionnée sont copiées puis transposées dans la colonne D de la feuille "Remplissage", et les en-têtes correspondantes (ligne 6 de la feuille "Infos") sont copiées et transposées dans la colonne C de la feuille "Remplissage.

Ce que je voudrais, c'est que lorsque je sélectionne ma ligne à copier et transposer, je voudrais qu'il y ait seulement les cellules comprises entre les colonnes A et Z, ainsi que les en-tête correspondantes (j'ai mis un exemple de ce que je voudrais avoir dans la feuille "Remplissage").

A noter, je dois garder le mode de sélection des données, a savoir cliquer sur le numéro de ligne puis utiliser un bouton clique.

Merci par avance,

Bonjour,

D'abord supprimer la ligne vide entre la ligne d'en-tête et le reste.

Ensuite seule la cellule active sera prise en considération lors de la sélection au démarrage. On peut se contenter de ne sélectionner qu'une seule cellule n'importe où sur la ligne avant de lancer la macro.

Hormis le prélèvement de la ligne de la cellule active au départ, et l'activation de la feuille cible en fin (pour montrer résultat), aucun Select ou Activate dans le code, de même que l'on ne procède pas par copier-coller, ainsi que le permet VBA, plus efficacement.

Sub test()
    Dim Tft(1), Tbl, n%
    With Worksheets("Infos")
        If .FilterMode Then .ShowAllData
        Tbl = .Range("A6").CurrentRegion.Resize(, 26).Value
    End With
    n = ActiveCell.Row - 5
    With Worksheets("Remplissage").Range("C8")
        .CurrentRegion.Clear
        If n > 1 Then
            Tft(0) = WorksheetFunction.Index(Tbl, 1, 0)
            Tft(1) = WorksheetFunction.Index(Tbl, n, 0)
            With .Resize(26, 2)
                .Value = WorksheetFunction.Transpose(Tft)
                .Borders.Weight = xlThin
                .Columns(1).Interior.Color = RGB(198, 224, 180)
            End With
        End If
        .Worksheet.Activate
    End With
End Sub

Cordialement.

Bonjour, merci pour votre aide.

J'ai oublié de préciser que le fichier joint était un exemple de mon vrai fichier, ce dernier étant beaucoup plus complexe.

En effet, la ligne des en-têtes comporte différentes couleurs et mise en forme. Avec

" Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _

, Transpose:=True", j'avais le mise en forme qui allait avec.

Avec votre code je ne l'ai plus. Avez-vous une solution ?

P¨S : exemple dans la pj

Cordialement,

Le code mettait la couleur indiquée sur le modèle... Tu sauras que le modèle sert justement à préciser le résultat à obtenir, alors n'en fournit pas un alors que tu veux autre chose qui ne figure pas !

Sub test()
    Dim Tft(1), Tbl, clr, ccl, n%, i%
    With Worksheets("Infos")
        If .FilterMode Then .ShowAllData
        Tbl = .Range("A6").CurrentRegion.Resize(, 26).Value
    End With
    n = ActiveCell.Row - 5
    With Worksheets("Remplissage").Range("C8")
        .CurrentRegion.Clear
        If n > 1 Then
            clr = Array(RGB(255, 192, 0), RGB(123, 123, 123), RGB(91, 155, 213), RGB(198, 224, 180))
            ccl = Array(1, 11, 12, 3, 15, 1, 16, 11)
            Tft(0) = WorksheetFunction.Index(Tbl, 1, 0)
            Tft(1) = WorksheetFunction.Index(Tbl, n, 0)
            With .Resize(26, 2)
                .Value = WorksheetFunction.Transpose(Tft)
                .Borders.Weight = xlThin
                For i = 0 To UBound(ccl) Step 2
                    .Cells(ccl(i), 1).Resize(ccl(i + 1)).Interior.Color = clr(i \ 2)
                Next i
                .Columns(1).Font.Size = 16
                .Cells(15, 1).Font.Italic = True
                .Cells(16, 1).Font.Color = vbRed
                With .Cells(17, 1).Font
                    .Bold = True: .Italic = True: .Underline = xlUnderlineStyleSingle
                End With
                With .Cells(18, 1).Resize(2).Font
                    .Size = 24: .Italic = True: .Underline = xlUnderlineStyleSingle
                End With
            End With
        End If
        .Worksheet.Activate
    End With
End Sub