[VBA] Vitesse exec code - écrire dans une plage de données

Bonsoir,

Dans mon projet, il y a un moment où il faut consacrer un peu de temps pour réaliser des correspondances entre des "habitats optimaux" avec des "habitats observés". Il peu y avoir plusieurs "habitats observés" pour 1 ou plusieurs "habitats optimaux".

Dans mon document, les "habitat optimaux" sont listés (feuille "LISTE_FLORE" colonne "Habitat") et apparaissent dans une listbox ; les "habitats observés" (feuille "JOINTURE" colonne "LIB_PHYSIO") doivent être associés via des clics entre les deux listboxes.

Deux autres listboxes permettent de visualiser les habitats ou espèces associés à chaque sélection (pas utile dans notre cas).

Pour chaque correspondance, des lignes sont ajoutées si nécessaires (+ de 1 correspondance), pour chaque espèce dont l'habitat optimal correspond.

Tout fonctionne bien, sauf que dans certaines situations (beaucoup de correspondances et beaucoup d'espèces), le temps d'exécution du code peut être très clairement allongé... Et je me dit que peut-être vous sauriez me dire comment diminuer ce temps d'exécution (par exemple en utilisant des tableaux plutôt qu'en travaillant directement sur les plages de données ?).

Pour conclure, la macro qui me pose ce problème est celle associée au bouton "VALIDER / SUIVANT"

Private Sub CommandButton1_Click()
Dim lrlf&, a%, i%, b%, c%, e%, f%, g%, ha As Byte, hz As Byte, nb1%, nb2%, aa, tabl()

    For a = 0 To Me.list_hab_bsfl.ListCount - 1
        If Me.list_hab_bsfl.Selected(a) Then nb1 = nb1 + 1
    Next a
    For a = 0 To Me.List_hab_join.ListCount - 1
        If Me.List_hab_join.Selected(a) Then nb2 = nb2 + 1
    Next a
    If nb1 = 0 Then MsgBox "Vous n'avez sélectionné aucune ligne dans la liste ""HABITATS D'ESPECES"" ", , "Absence de sélection": Me.Repaint: Exit Sub
    If nb2 = 0 Then MsgBox "Vous n'avez sélectionné aucune ligne dans la liste ""HABITAT ZONE D'ETUDE""", , "Absence de sélection": Me.Repaint: Exit Sub

With lf
aa = .Range("A1").CurrentRegion
lrlf = .Cells(.Rows.Count, 1).End(xlUp).Row
ha = .Range("1:1").Find("Habitat", LookIn:=xlValues).Column
hz = .Range("1:1").Find("Habitats_ZE", LookIn:=xlValues).Column

    For i = 0 To Me.list_hab_bsfl.ListCount - 1
        If Me.list_hab_bsfl.Selected(i) Then
            For a = lrlf To 2 Step -1
                If .Cells(a, ha) = Me.list_hab_bsfl.List(i, 0) Then
                    If nb2 > 1 Then .Cells(a, ha).Resize((nb2 - 1), 1).EntireRow.Insert
                    If nb2 = 1 And .Cells(a, hz) <> "" Then .Cells(a, ha).Resize(1, 1).EntireRow.Insert
                lrlf = .Cells(.Rows.Count, 1).End(xlUp).Row
                End If
            Next a
        End If
    Next i

lrlf = .Cells(.Rows.Count, 1).End(xlUp).Row
If nb2 = 1 Then
    For a = lrlf To 2 Step -1
        For i = 0 To Me.list_hab_bsfl.ListCount - 1
            If Me.list_hab_bsfl.Selected(i) Then
                If .Cells(a, ha) = Me.list_hab_bsfl.List(i, 0) Then
                    For e = 0 To Me.List_hab_join.ListCount - 1
                        If Me.List_hab_join.Selected(e) Then
                            If .Cells(a, hz) = "" Then .Cells(a, hz) = Me.List_hab_join.List(e, 2) Else: GoTo 1
                        End If
                    Next e
                End If
            End If
        Next i
    Next a
End If
If nb2 > 1 Then
1    For a = lrlf To 2 Step -1
        If .Cells(a, ha) = "" Then
    e = 0: c = a
        For b = a To 2 Step -1
            If .Cells(b, ha) = "" Then e = e + 1 Else Exit For
        Next b
        ReDim tabl(1 To e + 1, 1 To hz)
            For f = 1 To e + 1
                For g = 1 To hz
                    tabl(f, g) = .Cells((a + 1), g)
                Next g
            Next f
            f = 1
                For i = 0 To Me.List_hab_join.ListCount - 1
                    If Me.List_hab_join.Selected(i) Then
                        tabl(f, hz) = Me.List_hab_join.List(i, 2): f = f + 1
                    End If
                Next i
                .Cells((c + 1 - e), 1).Resize((f - 1), hz) = tabl
        End If
    Next a
End If
End With

    Call alim_listbox_bsfl
    Call alim_work
    Call opt_fin
Unload Userform_corr_habs
    Call check_empty
        If chk27 = 1 Then Userform_corr_habs.Show 'UserForm_correspondances.annexes_Click
        If chk27 = 0 Then Call chk28_1: UserForm_correspondances.annexes_Click: Exit Sub
End Sub

Je joins mon document à ce post.

Je vous remercie de votre attention,

Bonne fin de journée !

Bonsoir,

les inserts de lignes sont long, toutes modifications de données sur une feuille engendre le recalcul, afficher ces modifications augmente le temps...

Essayez en ajoutant ceci au début du code :

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

et en fin de code ou avant de quitter la procédure s'il y a des embranchements multiples :

With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With

@ bientôt

LouReeD

Bonsoir,

Effectivement dans mon exemple je n'ai pas ajouté cette partie du code, néanmoins tout cela est bien appliqué avant l'ouverture de l'UserForm via un module.

Merci