Erreur (Bug Excel ?) de transfert données d'une variable tableau VBA vers une plage filtrée

Version imprimable

Bonjour à Tous,

j'ai des problèmes pour transférer des données d'une variable VBA vers le classeur :

si le tableau n'est pas filtré : pas de soucis
si le tableau est filtré : des données aberrantes insérées !!!

Voici une macro qui présente le problème / Bug d'Excel ?

Code:

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
Sub Macro1()
    '\création d'un tableau temporaire pour l'expérience
        Columns("A:I").Delete Shift:=xlToLeft
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$I$50000"), , xlNo).Name = "TableauTEST"
        [TableauTEST].ListObject.TableStyle = "TableStyleLight9"
        For i = 1 To [TableauTEST].ListObject.DataBodyRange.Rows.Count
            [TableauTEST].ListObject.DataBodyRange.Cells(i, 1) = Int(Rnd * 10) + 1
        Next
 
    'fait des calculs sur une variable tableau (liée au tableau créé)
        Dim t():    t() = [TableauTEST].ListObject.DataBodyRange.Columns(1).Value
        For i = 1 To [TableauTEST].ListObject.DataBodyRange.Rows.Count
            t(i, 1) = t(i, 1) + 1
        Next
 
    'essai d'insertion du résultat sous différentes formulations vba
        [TableauTEST].ListObject.DataBodyRange.Columns(2) = t
        [TableauTEST].ListObject.DataBodyRange.Columns(3).Value = t
        Range([TableauTEST].ListObject.DataBodyRange.Columns(4).Address).Value = t
        For i = 1 To [TableauTEST].ListObject.DataBodyRange.Rows.Count '!!! Durée de réalisation
            [TableauTEST].ListObject.DataBodyRange.Cells(i, 5).Value = t(i, 1)
        Next
 
    'FILTRE DU TABLEAU :
        [TableauTEST].ListObject.Range.AutoFilter Field:=1, Criteria1:=1
 
    'RE-essai d'insertion du résultat sous différentes formulations vba
 
        '\\\ Les 3 lignes suivantes n'insèrent pas les bonnes données !!!!
        [TableauTEST].ListObject.DataBodyRange.Columns(6) = t
        [TableauTEST].ListObject.DataBodyRange.Columns(7).Value = t
        Range([TableauTEST].ListObject.DataBodyRange.Columns(8).Address).Value = t
 
        'celle-ci dessous fonctionne mais !!! Durée de réalisation
        For i = 1 To [TableauTEST].ListObject.DataBodyRange.Rows.Count '!!! Durée de réalisation
            [TableauTEST].ListObject.DataBodyRange.Cells(i, 9).Value = t(i, 1)
        Next
 
    'supprimer les filtres
        [TableauTEST].ListObject.Range.AutoFilter Field:=1
        'les colonnes 6/7/8 sont Aberrantes  !!!!!!!!!
End Sub

merci de votre aide pour résoudre ce problème

19/10/2020, 13h10
Zeabon
Bonjour bravojr,

Est-ce que la suppression des filtres avant l’implantation des données résoudrait ton problème ?
(possibilité de sauvegarder les filtres avant suppression pour les réimplanter : https://www.developpez.net/forums/d1...tomatique-vba/)
Code:

1 2 3 4 If Workbooks(XX).Sheets(???).FilterMode = True Then Workbooks(XX).Sheets(???).ShowAllData End If
Les filtres sont souvent problématiques dans Excel.
Si tu souhaites garder les filtres en faisant ta manipulation, alors je n'ai pas de proposition et te souhaites bon courage.

Zeabon
19/10/2020, 13h41
cavo789

Bonjour

En effet, +1 avec Zeabon: il faut d'abord désactiver le filtre sinon le résultat est des plus inattendus.

Citation:

Envoyé par Zeabon

Est-ce que la suppression des filtres avant l’implantation des données résoudrait ton problème ?
(possibilité de sauvegarder les filtres avant suppression pour les réimplanter : https://www.developpez.net/forums/d1...tomatique-vba/)
Zeabon

Bonjour,

Merci je me suis inspiré du lien fourni pour créer des fonctions de sauvegarde et de ré-application des filtres, je les partage en espérant que cela aide d'autres utilisateurs :

Fonction de sauvegarde des filtres

Code:

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
44
45
46
47
48
Option Explicit
Option Base 1
 
Function TblFiltres_Svg(LstObj As ListObject) As Variant
    If Not LstObj.AutoFilter.FilterMode Then
        TblFiltres_Svg = ""
        Exit Function
    End If
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim c As Range
    Dim mDico As New Dictionary '[Microsoft Scripting Runtime] doit être coché dans Outils/Référence
    Dim ErrDtGrp As Boolean
    With LstObj.AutoFilter.Filters
        For j = 1 To .Count ' Compte le nb de colonne avec filtre actif
            If .Item(j).On Then i = i + 1
        Next
        ReDim TableauFiltres(1 To 4, 1 To i)
        For j = 1 To .Count 'pour chaque colonne
            With .Item(j)
                If .On Then
                    k = k + 1
                    TableauFiltres(1, k) = j
                    On Error Resume Next
                    TableauFiltres(2, k) = .Criteria1
                    If Err.Number <> 0 Then
                        On Error GoTo 0
                        ActiveWindow.AutoFilterDateGrouping = False
                        For Each c In LstObj.ListColumns(j).DataBodyRange.SpecialCells(xlVisible)
                            If Not mDico.exists(c.Text) Then mDico(c.Text) = c.Text
                        Next
                        TableauFiltres(4, k) = mDico.items
                        Set mDico = Nothing
                    Else
                        On Error Resume Next
                        TableauFiltres(4, k) = .Criteria2
                        On Error GoTo 0
                    End If
                    On Error GoTo 0
                    TableauFiltres(3, k) = .Operator
                End If
            End With
        Next
    End With
    LstObj.AutoFilter.ShowAllData
    TblFiltres_Svg = TableauFiltres
End Function

Fonction de ré-application des filtres

Code:

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
44
45
46
47
Option Explicit
Option Base 1
 
Sub TblFiltres_Appl(LstObj As ListObject, TableauFiltres As Variant)
    Dim i As Long
    On Error Resume Next
    i = UBound(TableauFiltres, 1)
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
    For i = 1 To UBound(TableauFiltres, 2)
        ActiveSheet.ListObjects(1).Range.AutoFilter Field:=TableauFiltres(1, i)
        Dim Crit1 As Boolean
        Dim Crit2 As Boolean
        If IsArray(TableauFiltres(2, i)) Then
            Crit1 = True
        Else
            If TableauFiltres(2, i) <> "" Then Crit1 = True
        End If
        If IsArray(TableauFiltres(4, i)) Then
            Crit2 = True
        Else
            If TableauFiltres(4, i) <> "" Then Crit2 = True
        End If
        If Crit1 = True And Crit2 = False Then
            If TableauFiltres(3, i) = 0 Then
                LstObj.Range.AutoFilter Field:=TableauFiltres(1, i), Criteria1:=TableauFiltres(2, i)
            Else
                LstObj.Range.AutoFilter Field:=TableauFiltres(1, i), Criteria1:=TableauFiltres(2, i), Operator:=TableauFiltres(3, i)
            End If
        End If
        If Crit1 = True And Crit2 = True Then
                ActiveWindow.AutoFilterDateGrouping = False
                LstObj.Range.AutoFilter Field:=TableauFiltres(1, i), Criteria1:=TableauFiltres(2, i), Operator:=TableauFiltres(3, i), Criteria2:=TableauFiltres(4, i)
        End If
        If Crit1 = False And Crit2 = True Then
            If TableauFiltres(3, i) = 0 Then
                LstObj.Range.AutoFilter Field:=TableauFiltres(1, i), Criteria1:=TableauFiltres(4, i)
            Else
                ActiveWindow.AutoFilterDateGrouping = False
                LstObj.Range.AutoFilter Field:=TableauFiltres(1, i), Criteria1:=TableauFiltres(4, i), Operator:=TableauFiltres(3, i)
            End If
        End If
        Crit1 = False
        Crit2 = False
    Next i
    ActiveWindow.AutoFilterDateGrouping = True
End Sub

Exemple d'utilisation

Code:

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
44
45
46
47
Option Explicit
Option Base 1
 
Sub TEST()
    Dim i As Long
    Dim j As Long
    '\création d'un tableau temporaire pour l'expérience
        Columns("A:I").Delete Shift:=xlToLeft
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$I$50000"), , xlNo).Name = "TableauTEST"
        Dim tData()
        With [TableauTEST].ListObject.DataBodyRange
            tData() = .Value
            For i = 1 To .Rows.Count
                For j = 1 To .Columns.Count - 1
                    tData(i, j) = Int(Rnd * 10) + 1
                Next
                tData(i, .Columns.Count) = Date + Int((Rnd - 0.5) * 60)
            Next
            [TableauTEST].ListObject.DataBodyRange.Value = tData
        End With
        ActiveWindow.AutoFilterDateGrouping = True
        With [TableauTEST].ListObject.Range
            Dim s As String
            s = Format(Now, "MM/dd/yyyy")
            .AutoFilter Field:=9, Operator:=xlFilterValues, Criteria2:=Array(1, s)
            .AutoFilter Field:=2, Criteria1:="5"
            .AutoFilter Field:=7, Criteria1:="6"
        End With
    '\Fin de création d'un tableau temporaire pour l'expérience
 
    Dim Filtres As Variant
 
    '//Sauvegarde des filtres
    Filtres = TblFiltres_Svg([TableauTEST].ListObject)
 
    '//Fait les actions nécessaires (le tableau n'est plus filtré)
    Dim t(): t() = [TableauTEST].ListObject.DataBodyRange.Value
    For i = LBound(t, 1) To UBound(t, 1)
        For j = LBound(t, 2) To UBound(t, 2)
            If t(i, j) < 5 Then t(i, j) = -t(i, j)
        Next
    Next
    [TableauTEST].ListObject.DataBodyRange.Value = t
 
    '//Réapplication des filtre sauvegardés
    TblFiltres_Appl [TableauTEST].ListObject, Filtres
End Sub