Transposer partiellement un fichier

Bonjour

dans le fichier joint en fiche résultat sont rapatriés les aides du tableau 2 de l'onglet Feuil 1 et je cherche à rapatrier dans une nouvelle colonne (F) de l'onglet résultat les éléments du tableau 3 de l'onglet feuil1, mais je n'y parviens pas.

Voici le code qui a été inséré en feuille résultat, je souhaite le modifier pour intégrer les éléments du tableau 3 de l'onglet Feuil1.

Option Explicit

Private Sub Worksheet_Activate()

Dim tablo1, nlig&, tablo2, tablo3, ncol%, j%, i&, n&

With Feuil1

tablo1 = .[A1].CurrentRegion.Resize(, 3)

nlig = UBound(tablo1)

If nlig = 1 Then GoTo 1

tablo2 = .[E1].CurrentRegion.Resize(nlig)

ncol = UBound(tablo2, 2)

End With

'---tableau des résultats---

ReDim resu(1 To ncol * (nlig - 1), 1 To 6)

For j = 1 To ncol

For i = 2 To nlig

If tablo2(i, j) <> "" Then

n = n + 1

resu(n, 1) = tablo2(1, j)

resu(n, 2) = tablo1(i, 1)

resu(n, 3) = tablo1(i, 2)

resu(n, 4) = tablo1(i, 3)

resu(n, 5) = tablo2(i, j)

End If

Next i, j

'---restitution---

1 If FilterMode Then ShowAllData 'si la feuille est filtrée

With [A2] 'cellule de restitution, à adapter

If n Then

.Resize(n, 5) = resu

.Resize(n, 5).Borders.Weight = xlThin 'bordures

End If

.Offset(n).Resize(Rows.Count - n - .Row + 1, 5).Delete xlUp 'RAZ en dessous

End With

With UsedRange: End With 'actualise la barre de défilement verticale

End Sub

Salut jmx 37,

quelque chose comme ça ?

Un double-clic en feuille 'Aides' démarre la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, iRow%, iRowT1%, iRowT2%
'
Cancel = True
iRow = Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("Résultat")
    .Cells.Delete
    iRowT1 = 1
    .[A1] = "Tableau des aides de la semaine"
    With .Range("A1:F1")
        .Merge
        .BorderAround Weight:=xlMedium
        .Interior.ColorIndex = 16
        .HorizontalAlignment = xlHAlignCenter
        .Font.Bold = True
    End With
    For x = 5 To 8
        For y = 2 To iRow
            If y = 2 Then
                .Range("A" & iRowT1 + 1).Value = Cells(1, x)
                iRowT2 = iRowT1 + 1
            End If
            If Range(Chr(64 + x) & y).Value <> "" Then
                iRowT1 = iRowT1 + 1
                .Range("B" & iRowT1).Resize(1, 3).Value = Range("A" & y).Resize(1, 3).Value
                .Range("E" & iRowT1).Value = Cells(y, x)
                .Range("F" & iRowT1).Value = Cells(y, x).Offset(0, 5)
            End If
            If y = iRow Then
                .Range("A" & iRowT2 & ":A" & iRowT1).Merge
                .Range("A" & iRowT2).VerticalAlignment = xlVAlignTop
                .Range("A" & iRowT2 & ":F" & iRowT1).BorderAround Weight:=xlMedium
                .Range("A" & iRowT2 & ":F" & iRowT1).Interior.ColorIndex = IIf(.Range("A" & iRowT2 - 1).Interior.ColorIndex > 2, 2, 15)
            End If
        Next
    Next
    Union(.Range("A2:A" & iRowT1), .Range("D2:D" & iRowT1)).Borders(xlEdgeRight).LineStyle = xlContinuous
    .Range("F2:F" & iRowT1).Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Activate
End With
'
End Sub

A+