Discussion :

[sophieee]

Bonsoir à tous,

Je vous sollicite pour une macro que j'utilise comme filtre auto.
Pour accélérer le filtre, je transpose sur une autre feuille les résultats du filtre.

Mon soucis est que la transposition ne prend pas en compte le format des cellules
Ci dessous le code utilisé.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
If bActiver = False Then Exit Sub
 
    Dim n&, j&, ln%, i%, k%, conseil, etat$, tablo()
    If Target.Cells(1, 1) = "" Or Target.Count > 1 Then Exit Sub
    ' si case vide  pas de procédure
    Set sh = Sheets("Liste Demandes")
    sh.Range("B2").CurrentRegion.Offset(1).ClearContents
    ln = Me.Range("A" & Rows.Count).End(xlUp).Row
    If Not Intersect(Target, Me.Range("C5:h" & ln)) Is Nothing Then
        etat = Me.Cells(4, Target.Column)
        If Target.Row = ln Then
            For i = 5 To ln - 1
                conseil = conseil & ";" & Me.Cells(i, 1)
            Next i
        Else
            conseil = ";" & Me.Range("A" & Target.Row)
        End If
        conseil = Split(conseil, ";")
        With Worksheets("Stock Demandes")
            n = .Range("K" & .Rows.Count).End(xlUp).Row
            For j = 3 To n
                If .Cells(j, 6) = etat Then
                    For i = 1 To UBound(conseil)
                        If .Cells(j, 11) = conseil(i) Then Exit For
                    Next i
                    If i <= UBound(conseil) Then
                        k = k + 1: ReDim Preserve tablo(2 To 13, 1 To k)
                        For i = 2 To 13
                            tablo(i, k) = .Cells(j, i)
                        Next i
                    End If
                End If
            Next j
        End With
        With Worksheets("Liste Demandes")
            .Range("B2").Resize(k, 12).Value = WorksheetFunction.Transpose(tablo)
            .Visible = xlSheetVisible
            .Activate
        End With
    End If
End sub

Merci d'avance pour votre aide.
Sophie

[patricktoulon]

bonsoir
fait plutôt une recherche sur

" sheets(x).range(x,y).copy destination:=sheets(y).range(x)

range(x) est la première cellule en haut a gauche de la destination

[sophieee]

Bonsoir, j'ai essayé mais le tri à effectuer concerne plus de 15000 lignes.
Du coup cette solution prend une quinzaine de secondes.

La transposition est instantané.
Je pensais que l'on pouvait transposer avec le format

Merci pour votre réponse
Sophie