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

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

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

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