Boucle à l'aide de valeurs d'ìndex de filtre Résolu/Fermé

Question

Bonjour, 


Je cherche à créer une macro pour pouvoir traiter un nombre important de données. 
Mon tableau comporte trois colonnes (coordonnées en x, coordonnées en y et vitesse) pour un nombre variable de lignes suivant le fichier à traiter.

J'ai créé une Macro qui permet de filtrer les données du tableau suivant les valeurs de la première colonne. Ensuite la Macro sélectionne la première valeur du filtre, et copie les valeurs visibles de la colonne 'vitesse' dans une autre feuille  en les transposant.

Ce que j'aimerai maintenant, c'est pouvoir créer une boucle pour que la Macro prenne successivement toutes les valeurs du filtre et copie pour chacune de ces valeurs de filtre les valeurs visibles de la colonne vitesse, pour obtenir au final une matrice (avec chaque ligne correspondant aux valeurs de la vitesse pour une valeur donnée de filtre. La première ligne correspondant à la plus petite valeur de filtre, et la dernière ligne correspondant à la plus grande valeur de filtre).

Merci d'avance,


PS : Voici la matrice qui traite les données mais sans la boucle si vous voulez avoir une meilleure idée de ce que je souhaite obtenir:




Sub traiter_vitesse()' Sort out values using a filter on x valuesSheets("Sheet1").SelectRange("A1:C10").Select    Selection.AutoFilterActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.ClearActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _        ("A1:A10"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _        xlSortNormal    With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort        .Header = xlYes        .MatchCase = False        .Orientation = xlTopToBottom        .SortMethod = xlPinYin        .Apply    End With' Filter x according to its first value and copying the corresponding velocity valuesActiveSheet.Range("$A$1:$C$10").AutoFilter Field:=1, Criteria1:="0"Sheets("Sheet1").SelectRange("C2:C10").Select    Selection.CopySheets(3).Select    Range("A1").Select    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _        False, Transpose:=TrueEnd Sub


Configuration: Windows 7 / Chrome 41.0.2272.89

Frenchie83 · Answer

Bonjour
Si j'ai bien compris
Sub Traiter_Vitesse()
    Application.ScreenUpdating = False
    Sheets("Sheet1").Select
    Nbx = [A10000].End(xlUp).Row
    Range("A1:C1").Select
    ActiveSheet.AutoFilterMode = False
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("A1:A" & Nbx), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Columns("A:A").Select
    Selection.Copy
    Range("I1").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Z1"), Unique:=True
    NbVal = [Z10000].End(xlUp).Row
    ReDim Crit(NbVal) As String
    For i = 2 To NbVal
        Crit(i) = Cells(i, 26)
    Next i
    
    For i = 2 To NbVal
        ActiveSheet.Range("$A$1:$C" & Nbx).AutoFilter Field:=1, Criteria1:=Crit(i)
        Sheets("Sheet1").Select
        Range("_FilterDataBase").Resize(, 3).SpecialCells(xlCellTypeVisible).Copy
        Sheets(3).Select
        Range("A" & [A10000].End(xlUp).Row + 1).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        If couleur = 8 Then couleur = 7 Else couleur = 8
        Selection.Interior.ColorIndex = couleur
        Sheets("Sheet1").Select
    Next i
    
    Sheets("Sheet1").Range("Z1:Z" & NbVal).Clear
    Sheets(3).Select
End Sub

A essayer
cdlt

Frenchie83 · Answer

Voilà
Sub Traiter_Vitesse()
    Application.ScreenUpdating = False
    Sheets("Sheet1").Select
    Nbx = [A10000].End(xlUp).Row
    Range("A1:C1").Select
    ActiveSheet.AutoFilterMode = False
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("A1:A" & Nbx), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Columns("A:A").Select
    Selection.Copy
    Range("I1").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Z1"), Unique:=True
    NbVal = [Z10000].End(xlUp).Row
    ReDim Crit(NbVal) As String
    For i = 2 To NbVal
        Crit(i) = Cells(i, 26)
    Next i
    
    For i = 2 To NbVal
        ActiveSheet.Range("$A$1:$C" & Nbx).AutoFilter Field:=1, Criteria1:=Crit(i)
        Sheets("Sheet1").Select
        ActiveSheet.Range("C1:C" & Nbx).SpecialCells(xlCellTypeVisible).Copy
        Sheets("Sheet3").Select
        Range("A" & [A10000].End(xlUp).Row + 1).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        If couleur = 8 Then couleur = 7 Else couleur = 8
        Selection.Interior.ColorIndex = couleur
        Sheets("Sheet1").Select
    Next i
    
    Sheets("Sheet1").Range("Z1:Z" & NbVal).Clear
    Sheets("Sheet3").Select
End Sub

Bonne soirée

Boucle à l'aide de valeurs d'ìndex de filtre

2 réponses

Discussions similaires