Suppression de toutes les 2ème et 3ème lignes à l'aide de VBA

Question

Je suis à la recherche d'informations sur la suppression rapide des deux tiers d'un ensemble de données de taille moyenne. Actuellement, j'importe les données délimitées par des espaces dans Excel à partir d'un fichier texte, et j'utilise une boucle pour supprimer les données ligne par ligne. La boucle commence sur la rangée la plus basse des données et supprime les lignes qui montent. Les données sont classées chronologiquement, et je ne peux pas simplement couper le premier ou les deux derniers tiers des données. Essentiellement, les données sont suréchantillonnées et trop de points de données sont trop proches les uns des autres. C'est un processus laborieusement lent, et je cherche juste une autre méthode.

Sub Delete() 

Dim n As Long 

n = Application.WorksheetFunction.Count(Range("A:A")) 

Application.Calculation = xlCalculationManual 

Do While n > 5 

n = n - 1 
Rows(n).Delete 
n = n - 1 
Rows(n).Delete 
n = n - 1 

Loop 

    Application.Calculation = xlCalculationAutomatic 

End Sub 

Answer 1

Utilisez une boucle qui permet au pas à pas par un certain nombre:

For i = 8 To n Step 3

Utilisez Union pour créer une gamme décousue stockée dans une variable de plage.

Set rng = Union(rng, .Range(.Cells(i + 1, 1), .Cells(i + 2, 1)))

Ensuite, supprimez tout à la fois.

rng.EntireRow.Delete

Une autre bonne habitude d'encourager est l'utilisation de TOUJOURS déclarer le parent de tous les objets de gamme. Comme votre code devient de plus en plus compliqué, ne pas déclarer que les parents peuvent conduire à des problèmes. Par l'intermédiaire du bloc With.

With Worksheets("Sheet1")

nous pouvons précéder tous les objets de gamme avec . pour indiquer le lien vers ce parent.

Set rng = .Range("A6:A7")

Sub Delete() 

Dim n As Long 
Dim i As Long 
Dim rng As Range 

Application.Calculation = xlCalculationManual 

With Worksheets("Sheet1") 'change to your sheet 
    n = Application.WorksheetFunction.Count(.Range("A:A")) 

    Set rng = .Range("A6:A7") 

    For i = 8 To n Step 3 
     Set rng = Union(rng, .Range(.Cells(i + 1, 1), .Cells(i + 2, 1))) 
    Next i 
End With 

rng.EntireRow.Delete 

Application.Calculation = xlCalculationAutomatic  


End Sub 

Answer 2

Vous pouvez utiliser des tableaux et d'écrire un tiers des lignes dans un nouveau tableau. Imprimez ensuite sur l'écran après avoir effacé l'original.

Vous perdriez des formules s'il y en a. Si vous n'aviez qu'un jeu de données de base, cela pourrait vous convenir. Il devrait être rapide

Sub MyDelete() 
    Dim r As Range 
    Set r = Sheet1.Range("A1").CurrentRegion 'perhaps define better 
    Set r = r.Offset(1, 0).Resize(r.Rows.Count - 1) ' I assume row 1 is header row. 

Application.ScreenUpdating = False 

    Dim arr As Variant 
    arr = r.Value 

    Dim newArr() As Variant 
    ReDim newArr(1 To UBound(arr), 1 To UBound(arr, 2)) 
    Dim i As Long, j As Long, newCounter As Long 
    i = 1 
    newCounter = 1 

    Do 
     For j = 1 To UBound(arr, 2) 
      newArr(newCounter, j) = arr(i, j) 
     Next j 

     newCounter = newCounter + 1 
     i = i + 3 
    Loop While i <= UBound(arr) 

    r.ClearContents 
    Sheet1.Range("A2").Resize(newCounter - 1, UBound(arr, 2)).Value = newArr 

Application.ScreenUpdating = True 

End Sub