XL 2013 Transposer une liste les cellules sélectionnées seulement dans une autre page

[mllemoon]

Bonjour,

J'ai fait un fichier Excel qui comporte une liste d'options que les gens sont invités à choisir en mettant un "X" dans la case adjacente à cette option. J'aimerais que la page 2 liste seulement les cellules avec un "X".

Est-ce possible?

Dans le fichier joint, c'est la feuille "Analyse du coutant" que j'aimerais voir se remplir toute seule.


Regarde la pièce jointe Test.xlsx

Je ne sais pas comment s'appelle ce que je cherche. Actuellement, j'ai recherché une formule mais sans succès. Je ne suis pas à l'aise avec les macros. Donc l'aide d'un pro serait vraiment al bienvenue. Ne croyez pas que je cherche à faire faire mon travail par un autre, je cherche surtout à apprendre dans tout ça.

Merci beaucoup pour votre aide.

 

[CHALET53]

Re : Transposer une liste les cellules sélectionnées seulement dans une autre page

Bonjour,

Un essai avec Petite Valeur

a+

 

[mllemoon]

Re : Transposer une liste les cellules sélectionnées seulement dans une autre page

Merci beaucoup, je l'ai mise dans mon "vrai" fichier et ajusté avec le nom de mes feuilles.

Qu'est-ce qui ne va pas d'après-toi?

=INDEX('800 Series'!$B$25:$B$51;PETITE.VALEUR(SI(('800 Series'!$H$25:$H$51="x");LIGNE('800 Series'!$B$25:$B$51)-1;"");LIGNE()-1))

PS: j'ai retiré sierreur car je n'avais pas de résultat.

La page s'appelle: 800 Series
Les données à extraire se trouvent dans $B$25:$B$51
Les "x" sont dans $H$25:$H$51

Merci encore

Bonjour,

Un essai avec Petite Valeur

a+

 

[klin89]

Re : Transposer une liste les cellules sélectionnées seulement dans une autre page

Bonsoir à tous,

Vois ceci :
A ajuster selon la structure de ton tableau.

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Byte
    Application.ScreenUpdating = False
    With Sheets("Liste de prix").Range("A2").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 3, 2))
    End With
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
    b(1, 1) = "Description": b(1, 2) = "Coutant"
    n = 1
    For i = 2 To UBound(a, 1)
        If a(i, 3) = "x" Then
            n = n + 1
            For j = 1 To UBound(a, 2) - 1
                b(n, j) = a(i, j)
            Next
        End If
    Next
    'Restitution et mise en forme
    With Sheets(2)
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Offset(.Rows.Count).Resize(1)
                    .Cells(1) = "Coutant total"
                    With .Cells(2)
                        .Formula = "=sum(r2c:r[-1]c)"
                        .NumberFormat = "_ * #,##0.00_) ""$""_ ;_ * (#,##0.00) ""$""_ ;_ * ""-""??_) ""$""_ ;_ @_ "
                    End With
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 19
                End With
                With .CurrentRegion
                    With .Rows(1)
                        .BorderAround Weight:=xlThin
                        .Interior.ColorIndex = 44
                    End With
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .VerticalAlignment = xlCenter
                    .Columns.AutoFit
                End With
            End With
        End With
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[klin89]

Re : Transposer une liste les cellules sélectionnées seulement dans une autre page

Re mllemoon

Suite à ton message privé.
Dans ton cas, pour rechercher les cases cochées, j'ai utilisé la propriété FindFormat
A tester, restitution en Feuil1.

Option Explicit

Sub Copier()
Dim b(), r As Range, ff As String, n As Long
    'le format recherché
    With Application.FindFormat
        .Clear
        .Font.Name = "calibri"
        .Font.Size = 7
        .Font.Bold = True
    End With
    ReDim b(1 To 1000, 1 To 3): n = 1
    b(n, 1) = "Reference": b(n, 2) = "Description": b(n, 3) = "Coutant"
    With Sheets("800 Series")
        Set r = .Cells.Find("*", SearchFormat:=True)
        If Not r Is Nothing Then
            ff = r.Address
            Do
                n = n + 1
                If r.Column = 25 Then
                    b(n, 1) = r.Offset(, -7).Value
                    b(n, 2) = r.Offset(, -6).Value
                    b(n, 3) = r.Offset(, -3).Value
                Else
                    b(n, 1) = r.Offset(, -6).Value
                    b(n, 2) = r.Offset(, -5).Value
                    b(n, 3) = r.Offset(, -3).Value
                End If
                Set r = .Cells.Find("*", r, SearchFormat:=True)
            Loop Until ff = r.Address
        Else
            MsgBox "Aucune donnée à traiter": Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    'Restitution et mise en forme
    With Sheets("Feuil1")
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Offset(.Rows.Count).Resize(1)
                    .Cells(1) = "Totaux"
                    With .Cells(3)
                        .Formula = "=sum(r2c:r[-1]c)"
                        .NumberFormat = "_ * #,##0.00_) ""$""_ ;_ * (#,##0.00) ""$""_ ;_ * ""-""??_) ""$""_ ;_ @_ "
                    End With
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 19
                End With
                With .CurrentRegion
                    With .Rows(1)
                        .BorderAround Weight:=xlThin
                        .Interior.ColorIndex = 44
                    End With
                    .Font.Name = "calibri"
                    .Font.Size = 10
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    .VerticalAlignment = xlCenter
                    .Columns.AutoFit
                End With
            End With
        End With
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub

Pour bien comprendre l'utilisation de la propriété Findformat
Vois cette macro :

Sub Selection()
Dim r As Range, ff As String, x As Range
'le format recherché
    With Application.FindFormat
        .Clear
        .Font.Name = "calibri"
        .Font.Size = 7
        .Font.Bold = True
    End With
    With Sheets("800 Series")
        Set r = .Cells.Find("*", SearchFormat:=True)
        If Not r Is Nothing Then
            ff = r.Address
            Do
                If x Is Nothing Then
                    Set x = r
                Else
                    Set x = Union(x, r)
                End If
                Set r = .Cells.Find("*", r, SearchFormat:=True)
            Loop Until ff = r.Address
        End If
    End With
    If Not x Is Nothing Then
        'on sélectionne les cellules concernées
        x.Select
    Else
        MsgBox "Pas de cellules au format recherché"
    End If
End Sub

klin89

 

[mllemoon]

Re : Transposer une liste les cellules sélectionnées seulement dans une autre page

Merci infiniment, tu es génial! Je vais travailler avec mon fichier maintenant. Je te souhaite une superbe fin de semaine.
Merci

Karine