Optimisation VBA

Bonjour tout le monde,

Me voilà enfin tranquille avec mon gros bloc de code VBA, mais comme je suis mauvais (même très mauvais je dirais ) en optimisation VBA (vue que je suis encore assez novice déjà juste dans l'écriture du code), j'aurais besoin de votre aide pour voir s'il est possible d'optimiser mon code actuel (je ne sais pas si vous allez avoir besoin du fichier, si oui je vais voir pour faire du nettoyage massif)

Voici mon code :

Sub Data_manquantes()

    Dim DernLigne As Long, Lig As Long
    Dim TabLig() As String
    Dim Ws As Worksheet
    Dim tablo
    Dim i&, j&, k&

c = Timer

' Ajout des colonnes pour inclure les données manquantes
'

Feuil1.Activate
    ActiveSheet.Range("AO1").Value = "Type de donnees de publication web a renseigner"
    ActiveSheet.Range("AP1").Value = "Attributs manquants pour la publication"
    ActiveSheet.Range("AQ1").Value = "Nombre d'attributs manquants"

' Recherche du fichier avec les données manquantes et ajout de celles-ci dans nouvel onglet sur 1er ficher

Application.ScreenUpdating = False

Set fileB = Workbooks.Open("C:\Users\XXX\Documents\XXX\Data manquante rapport de pub.xlsx")
     fileB.Sheets("Sheet1").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
     fileB.Close

' Intégration des nouvelles données dans les bons onglets

Feuil1.Activate
    ActiveSheet.Range("AO2").Formula = _
        "=IFERROR(INDEX(Sheet1!C[-40]:C[-38],MATCH(FIXED(R[1]C[-39],0,1),Sheet1!C[-40],0),2),""Aucune"")"
    ActiveSheet.Range("AP2").Formula = _
        "=IFERROR(INDEX(Sheet1!C[-41]:C[-39],MATCH(FIXED(R[1]C[-40],0,1),Sheet1!C[-41],0),3),""Aucun"")"

' Faire descendre les formules dans les colonnes

    With Worksheets(1)
        DernLigne = .Range("B" & .Rows.Count).End(xlUp).Row
        .Range("AO2").AutoFill Destination:=.Range("AO2:AO" & DernLigne)
        .Range("AP2").AutoFill Destination:=.Range("AP2:AP" & DernLigne)
    End With

' Compter le nombre d'attributs manquants
  ' Pour chaque ligne
  For Lig = 2 To DernLigne
    ' Récupérer le tableau des tirets
    TabLig = Split(Range("AP" & Lig), "-")
    ' Inscrire le nombre d'attributs manquants
    Range("AQ" & Lig).Value = UBound(TabLig) & " attribut(s) manquant(s)"
  Next Lig

    'Déclaration des Objets
    Set Ws = ThisWorkbook.Worksheets(1)

    With Ws
        ' Ajout des colonnes pour inclure les données manquantes
        tablo = .Range("A1").CurrentRegion

        For i = 2 To UBound(tablo, 1)
                ' Intégration des nouvelles données dans le bon onglet
                If tablo(i, 16) <> Empty And tablo(i, 8) = "Active commerce" And tablo(i, 9) = "OUI" And (tablo(i, 10) = "DR" Or tablo(i, 10) = "") _
                    And tablo(i, 41) Like "*Média manquant*" Then
                        If tablo(i, 16) >= Date Then
                            tablo(i, 19) = 1
                            ElseIf tablo(i, 16) - Date < -1 And tablo(i, 16) - Date > -14 Then tablo(i, 19) = 2
                            ElseIf tablo(i, 16) - Date < -14 Then tablo(i, 19) = 3
                        End If
                Else
                    tablo(i, 19) = Empty
                End If
        Next i

        .Columns(1).Resize(UBound(tablo, 2)).ClearContents
        .Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    End With

    Set Ws = ThisWorkbook.Worksheets(1)

    With Ws
        tablo = .Range("A1").CurrentRegion

        For j = 2 To UBound(tablo, 1)
            If tablo(j, 16) <> Empty And tablo(j, 8) = "Active commerce" And tablo(j, 9) = "OUI" And (tablo(j, 10) = "DR" Or tablo(j, 10) = "") _
                And tablo(j, 41) Like "*Attribut manquant*" Then
                    If tablo(j, 16) >= Date Then
                        tablo(j, 18) = 1
                        ElseIf tablo(j, 16) - Date < -1 And tablo(j, 16) - Date > -14 Then tablo(j, 18) = 2
                        ElseIf tablo(j, 16) - Date < -14 Then tablo(j, 18) = 3
                    End If
                Else
                    tablo(j, 18) = Empty
                End If
            Next j
        .Columns(1).Resize(UBound(tablo, 2)).ClearContents
        .Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    End With

    Set Ws = ThisWorkbook.Worksheets(1)

    With Ws
        tablo = .Range("A1").CurrentRegion

        For k = 2 To UBound(tablo, 1)
            If tablo(k, 16) <> Empty And tablo(k, 8) = "Active commerce" And tablo(k, 9) = "OUI" And (tablo(k, 10) = "DR" Or tablo(k, 10) = "") _
                And tablo(k, 41) Like "*Nomenclature*" Then
                    If tablo(k, 16) >= Date Then
                        tablo(k, 20) = 1
                        ElseIf tablo(k, 16) - Date < -1 And tablo(k, 16) - Date > -14 Then tablo(k, 20) = 2
                        ElseIf tablo(k, 16) - Date < -14 Then tablo(k, 20) = 3
                    End If
                Else
                    tablo(k, 20) = Empty
                End If
            Next k
        .Columns(1).Resize(UBound(tablo, 2)).ClearContents
        .Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    End With

        Application.ScreenUpdating = True

   c = Timer - c

   Range("AU1") = c

End Sub

Merci d'avance à vous et bonne journée

Edit : Aujourd'hui la macro prend environ 20s en sachant que le fichier que la macro va chercher ne comporte que 3-4 colonnes (et pour le moment pas beaucoup de lignes mais ça peut grimper), alors que le fichier réception possède déjà pas mal de colonnes (40 en excluant celles ajoutées) et 51711 lignes

Bonjour

Après lecture rapide du code proposé (sans PJ c'est forcément plus difficile de se rendre compte) il y a tout de même certains points améliorable en terme d'optimisation 'basique' du code :

1) Dans la portion de code :

Feuil1.Activate
    ActiveSheet.Range("AO1").Value = "Type de donnees de publication web a renseigner"
    ActiveSheet.Range("AP1").Value = "Attributs manquants pour la publication"
    ActiveSheet.Range("AQ1").Value = "Nombre d'attributs manquants"

le Feuil1.Activate est inutile est ralentissant !

Utilise plutôt une déclaration du style :

Dim feuilleActuelle As Object   ' Dans les déclarations et cela est valable pour toutes les feuilles et/ou classeurs utilisé(e)s

Set feuilleActuelle = Worksheets("Feuil1)  ' En 1ère ligne de la procédure

With feuilleActuelle                    ' Utilise ensuite cette formulation dès que nécessaire !
   Range("AO1").Value = "..."
   Range("AP1").Value = "..."
   ...
End With
' Ne pas oublier !!!
Set feuilleActuelle = Nothing  ' En fin de procédure pour libérer la mémoire !

2) Place le "Application ScreenUpdating = False" en 1ère ligne 'utile' de la procédure après les déclarations 'SET' !

Ce n'est qu'une 1ère analyse, à suivre avec une PJ...

Bonjour à tous,

Avec un "With", ne devrait-il pas y avoir des points devant les "range" ?

Sinon, les "range" font référence à la feuille active, pas avec celle du "With".

With feuilleActuelle                    ' Utilise ensuite cette formulation dès que nécessaire !
   .Range("AO1").Value = "..."
   .Range("AP1").Value = "..."
   ...
End With

ric

(..)

@ric

Merci pour la correction, mon cher !

Tu as tout à fait raison : Autant proposer une amélioration qui fonctionne

J'ai juste indiqué quelques pistes rapides d'amélioration en vitesse et mes doigts ont sans doute dérapés sur le . (point)

(..)

@ric

Merci pour la correction, mon cher !

Tu as tout à fait raison : Autant proposer une amélioration qui fonctionne

J'ai juste indiqué quelques pistes rapides d'amélioration en vitesse et mes doigts ont sans doute dérapés sur le . (point)

Merci pour vos premières réponses je vais voir pour vous transmettre un document assez vierge (ou sans informations "secrètes" )

En tout cas vous m'aidez beaucoup alors un énorme merci à vous !

Voici le fichier :

Dedans il y a déjà le fichier qu'il va chercher (onglet Sheet1)

Je vous laisse découvrir je n'ai pas apporté les modifications données plus haut, car lorsque je le fais ma colonne ("nombres d'attributs manquants" est vide ... plus rien ne remonte je comprend pas trop pourquoi ...)

Si je suis pas très clair ou que mon fichier n'est pas clair, je ferais au mieux pour vous expliquer

PS : J'ai fais exprès de réduire drastiquement le nombre de ligne du 1er onglet et ne laisser que les N°commande présente dans les deux fichiers (dans mon vrai fichier j'ai bien plus de lignes dans le 1er onglet mais ici pas utile car pas de correspondance avec le second, j'ai aussi supprimé pas mal de données qui ne sont absolument pas utile dans les formules, mais elles ont bien des données).

Merci d'avance à vous

9vba.xlsm (734.84 Ko)

Bonjour à tous,

Je ne suis pas encore un expert des variables tableaux.

Je me suis donc contenté d'éliminer les multiples références à la Feuil1 en ne conservant qu'un "With" au début et le "End With" à la fin.

Spoiler

Sub Data_manquantes()

Dim DernLigne As Long, Lig As Long

Dim TabLig() As String

Dim Ws As Worksheet

Dim tablo

Dim i&, j&, k&

Application.ScreenUpdating = False

c = Timer

'Déclaration des Objets

Set Ws = ThisWorkbook.Worksheets(1)

With Ws

' Ajout des colonnes pour inclure les données manquantes

.Range("AO1").Value = "Type de donnees de publication web a renseigner"

.Range("AP1").Value = "Attributs manquants pour la publication"

.Range("AQ1").Value = "Nombre d'attributs manquants"

' Recherche du fichier avec les données manquantes et ajout de celles-ci dans nouvel onglet sur 1er ficher

Set fileB = Workbooks.Open("C:\Users\XXX\Documents\Suivi Pilotage\Data manquante rapport de pub.xlsx")

fileB.Sheets("Sheet1").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

fileB.Close

' Intégration des nouvelles données dans les bons onglets

.Range("AO2").Formula = "=IFERROR(INDEX(Sheet1!C[-40]:C[-38],MATCH(FIXED(R[1]C[-39],0,1),Sheet1!C[-40],0),2),""Aucune"")"

.Range("AP2").Formula = "=IFERROR(INDEX(Sheet1!C[-41]:C[-39],MATCH(FIXED(R[1]C[-40],0,1),Sheet1!C[-41],0),3),""Aucun"")"

' Faire descendre les formules dans les colonnes

DernLigne = .Range("B" & .Rows.Count).End(xlUp).Row

.Range("AO2").AutoFill Destination:=.Range("AO2:AO" & DernLigne)

.Range("AP2").AutoFill Destination:=.Range("AP2:AP" & DernLigne)

' Compter le nombre d'attributs manquants

' Pour chaque ligne

For Lig = 2 To DernLigne

' Récupérer le tableau des tirets

TabLig = Split(.Range("AP" & Lig), "-")

' Inscrire le nombre d'attributs manquants

.Range("AQ" & Lig).Value = UBound(TabLig) & " attribut(s) manquant(s)"

Next Lig

' Ajout des colonnes pour inclure les données manquantes

tablo = .Range("A1").CurrentRegion

For i = 2 To UBound(tablo, 1)

' Intégration des nouvelles données dans le bon onglet

If tablo(i, 16) <> Empty And tablo(i, 8) = "Active commerce" And tablo(i, 9) = "OUI" And (tablo(i, 10) = "DR" Or tablo(i, 10) = "") _

And tablo(i, 41) Like "*Média manquant*" Then

If tablo(i, 16) >= Date Then

tablo(i, 19) = 1

ElseIf tablo(i, 16) - Date < -1 And tablo(i, 16) - Date > -14 Then tablo(i, 19) = 2

ElseIf tablo(i, 16) - Date < -14 Then tablo(i, 19) = 3

End If

Else

tablo(i, 19) = Empty

End If

Next i

.Columns(1).Resize(UBound(tablo, 2)).ClearContents

.Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo

tablo = .Range("A1").CurrentRegion

For j = 2 To UBound(tablo, 1)

If tablo(j, 16) <> Empty And tablo(j, 8) = "Active commerce" And tablo(j, 9) = "OUI" And (tablo(j, 10) = "DR" Or tablo(j, 10) = "") _

And tablo(j, 41) Like "*Attribut manquant*" Then

If tablo(j, 16) >= Date Then

tablo(j, 18) = 1

ElseIf tablo(j, 16) - Date < -1 And tablo(j, 16) - Date > -14 Then tablo(j, 18) = 2

ElseIf tablo(j, 16) - Date < -14 Then tablo(j, 18) = 3

End If

Else

tablo(j, 18) = Empty

End If

Next j

.Columns(1).Resize(UBound(tablo, 2)).ClearContents

.Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo

tablo = .Range("A1").CurrentRegion

For k = 2 To UBound(tablo, 1)

If tablo(k, 16) <> Empty And tablo(k, 8) = "Active commerce" And tablo(k, 9) = "OUI" And (tablo(k, 10) = "DR" Or tablo(k, 10) = "") _

And tablo(k, 41) Like "*Nomenclature*" Then

If tablo(k, 16) >= Date Then

tablo(k, 20) = 1

ElseIf tablo(k, 16) - Date < -1 And tablo(k, 16) - Date > -14 Then tablo(k, 20) = 2

ElseIf tablo(k, 16) - Date < -14 Then tablo(k, 20) = 3

End If

Else

tablo(k, 20) = Empty

End If

Next k

.Columns(1).Resize(UBound(tablo, 2)).ClearContents

.Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo

c = Timer - c

.Range("AU1") = c

End With

Application.ScreenUpdating = True

End Sub

ric

Bonjour à tous,

Je ne suis pas encore un expert des variables tableaux.

Je me suis donc contenté d'éliminer les multiples références à la Feuil1 en ne conservant qu'un "With" au début et le "End With" à la fin.

Spoiler

Sub Data_manquantes()

Dim DernLigne As Long, Lig As Long

Dim TabLig() As String

Dim Ws As Worksheet

Dim tablo

Dim i&, j&, k&

Application.ScreenUpdating = False

c = Timer

'Déclaration des Objets

Set Ws = ThisWorkbook.Worksheets(1)

With Ws

' Ajout des colonnes pour inclure les données manquantes

.Range("AO1").Value = "Type de donnees de publication web a renseigner"

.Range("AP1").Value = "Attributs manquants pour la publication"

.Range("AQ1").Value = "Nombre d'attributs manquants"

' Recherche du fichier avec les données manquantes et ajout de celles-ci dans nouvel onglet sur 1er ficher

Set fileB = Workbooks.Open("C:\Users\XXX\Documents\Suivi Pilotage\Data manquante rapport de pub.xlsx")

fileB.Sheets("Sheet1").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

fileB.Close

' Intégration des nouvelles données dans les bons onglets

.Range("AO2").Formula = "=IFERROR(INDEX(Sheet1!C[-40]:C[-38],MATCH(FIXED(R[1]C[-39],0,1),Sheet1!C[-40],0),2),""Aucune"")"

.Range("AP2").Formula = "=IFERROR(INDEX(Sheet1!C[-41]:C[-39],MATCH(FIXED(R[1]C[-40],0,1),Sheet1!C[-41],0),3),""Aucun"")"

' Faire descendre les formules dans les colonnes

DernLigne = .Range("B" & .Rows.Count).End(xlUp).Row

.Range("AO2").AutoFill Destination:=.Range("AO2:AO" & DernLigne)

.Range("AP2").AutoFill Destination:=.Range("AP2:AP" & DernLigne)

' Compter le nombre d'attributs manquants

' Pour chaque ligne

For Lig = 2 To DernLigne

' Récupérer le tableau des tirets

TabLig = Split(.Range("AP" & Lig), "-")

' Inscrire le nombre d'attributs manquants

.Range("AQ" & Lig).Value = UBound(TabLig) & " attribut(s) manquant(s)"

Next Lig

' Ajout des colonnes pour inclure les données manquantes

tablo = .Range("A1").CurrentRegion

For i = 2 To UBound(tablo, 1)

' Intégration des nouvelles données dans le bon onglet

If tablo(i, 16) <> Empty And tablo(i, 8) = "Active commerce" And tablo(i, 9) = "OUI" And (tablo(i, 10) = "DR" Or tablo(i, 10) = "") _

And tablo(i, 41) Like "*Média manquant*" Then

If tablo(i, 16) >= Date Then

tablo(i, 19) = 1

ElseIf tablo(i, 16) - Date < -1 And tablo(i, 16) - Date > -14 Then tablo(i, 19) = 2

ElseIf tablo(i, 16) - Date < -14 Then tablo(i, 19) = 3

End If

Else

tablo(i, 19) = Empty

End If

Next i

.Columns(1).Resize(UBound(tablo, 2)).ClearContents

.Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo

tablo = .Range("A1").CurrentRegion

For j = 2 To UBound(tablo, 1)

If tablo(j, 16) <> Empty And tablo(j, 8) = "Active commerce" And tablo(j, 9) = "OUI" And (tablo(j, 10) = "DR" Or tablo(j, 10) = "") _

And tablo(j, 41) Like "*Attribut manquant*" Then

If tablo(j, 16) >= Date Then

tablo(j, 18) = 1

ElseIf tablo(j, 16) - Date < -1 And tablo(j, 16) - Date > -14 Then tablo(j, 18) = 2

ElseIf tablo(j, 16) - Date < -14 Then tablo(j, 18) = 3

End If

Else

tablo(j, 18) = Empty

End If

Next j

.Columns(1).Resize(UBound(tablo, 2)).ClearContents

.Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo

tablo = .Range("A1").CurrentRegion

For k = 2 To UBound(tablo, 1)

If tablo(k, 16) <> Empty And tablo(k, 8) = "Active commerce" And tablo(k, 9) = "OUI" And (tablo(k, 10) = "DR" Or tablo(k, 10) = "") _

And tablo(k, 41) Like "*Nomenclature*" Then

If tablo(k, 16) >= Date Then

tablo(k, 20) = 1

ElseIf tablo(k, 16) - Date < -1 And tablo(k, 16) - Date > -14 Then tablo(k, 20) = 2

ElseIf tablo(k, 16) - Date < -14 Then tablo(k, 20) = 3

End If

Else

tablo(k, 20) = Empty

End If

Next k

.Columns(1).Resize(UBound(tablo, 2)).ClearContents

.Range("A1").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo

c = Timer - c

.Range("AU1") = c

End With

Application.ScreenUpdating = True

End Sub

ric

Wow impressionnant je gagne 4 secondes sur le temps de réalisation

Grand merci à toi

A ton sens il est encore possible d'améliorer le truc ?

Bonjour

A mon avis et après lecture rapide du code de "ric" je pense que oui !

Je télécharge ta PJ pour faire quelques tests...

(..)

Pour infos

J'ai fais exprès de réduire drastiquement le nombre de ligne du 1er onglet et ne laisser que les N°commande présente dans les deux fichiers (dans mon vrai fichier j'ai bien plus de lignes dans le 1er onglet mais ici pas utile car pas de correspondance avec le second, j'ai aussi supprimé pas mal de données qui ne sont absolument pas utile dans les formules, mais elles ont bien des données).

pour le chrono, combien de lignes dans "ta version" non allégée ?

(..)

Pour infos

J'ai fais exprès de réduire drastiquement le nombre de ligne du 1er onglet et ne laisser que les N°commande présente dans les deux fichiers (dans mon vrai fichier j'ai bien plus de lignes dans le 1er onglet mais ici pas utile car pas de correspondance avec le second, j'ai aussi supprimé pas mal de données qui ne sont absolument pas utile dans les formules, mais elles ont bien des données).

pour le chrono, combien de lignes dans "ta version" non allégée ?

Hello,

Merci à toi pour l'aide, pour la version non allégé je suis à 51711 lignes (ça sera toujours plus ou moins ça), avec un chrono de 20s (pour ma formule moche) et 16s (pour la plus belle version de ric)

Encore merci à vous tous pour votre aide !

(..)

Ok pour 20sec. vs 16sec.

Première re-optimisation depuis la version de ric (sans aller jusqu'au bout du code qu'il a écrit), "mes optimisations" sont encadrées de '------------> Gli73/ <------------ Gli73'

Sub Data_manquantes()
Dim DernLigne As Long, Lig As Long
Dim TabLig() As String
Dim Ws As Worksheet
Dim tablo
Dim i&, j&, k&

'   -------------> Gli73
Dim fileB   As Workbook
Dim tabloTiret
'   <------------- Gli73

    Application.ScreenUpdating = False

    c = Timer

    'Déclaration des Objets
    Set Ws = ThisWorkbook.Worksheets(1)
    With Ws

        ' Ajout des colonnes pour inclure les données manquantes
        .Range("AO1").Value = "Type de donnees de publication web a renseigner"
        .Range("AP1").Value = "Attributs manquants pour la publication"
        .Range("AQ1").Value = "Nombre d'attributs manquants"

        ' Recherche du fichier avec les données manquantes et ajout de celles-ci dans nouvel onglet sur 1er ficher

        Set fileB = Workbooks.Open("C:\Users\XXX\Documents\Suivi Pilotage\Data manquante rapport de pub.xlsx")
        '   -------------> Gli73
        With fileB
            .Sheets("Sheet1").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            .Close
        End With
        '   <------------- Gli73

        ' Intégration des nouvelles données dans les bons onglets
        '   -------------> Gli73
        '.Range("AO2").Formula = "=IFERROR(INDEX(Sheet1!C[-40]:C[-38],MATCH(FIXED(R[1]C[-39],0,1),Sheet1!C[-40],0),2),""Aucune"")"
        '.Range("AP2").Formula = "=IFERROR(INDEX(Sheet1!C[-41]:C[-39],MATCH(FIXED(R[1]C[-40],0,1),Sheet1!C[-41],0),3),""Aucun"")"
        '
        '' Faire descendre les formules dans les colonnes
        '
        'DernLigne = .Range("B" & .Rows.Count).End(xlUp).Row
        '.Range("AO2").AutoFill Destination:=.Range("AO2:AO" & DernLigne)
        '.Range("AP2").AutoFill Destination:=.Range("AP2:AP" & DernLigne)
        DernLigne = .Cells(Rows.Count, 2).End(xlUp).Row
        Range(.Cells(2, 41), .Cells(DernLigne, 41)).Formula = "=IFERROR(INDEX(Sheet1!C[-40]:C[-38],MATCH(FIXED(R[1]C[-39],0,1),Sheet1!C[-40],0),2),""Aucune"")"
        Range(.Cells(2, 42), .Cells(DernLigne, 42)).Formula = "=IFERROR(INDEX(Sheet1!C[-41]:C[-39],MATCH(FIXED(R[1]C[-40],0,1),Sheet1!C[-41],0),3),""Aucun"")"
        '   <------------- Gli73

        ' Compter le nombre d'attributs manquants
        ' Pour chaque ligne
        '   -------------> Gli73
        'For Lig = 2 To DernLigne
        '    ' Récupérer le tableau des tirets
        '    TabLig = Split(.Range("AP" & Lig), "-")
        '    ' Inscrire le nombre d'attributs manquants
        '    .Range("AQ" & Lig).Value = UBound(TabLig) & " attribut(s) manquant(s)"
        'Next Lig
        '   Gli73 -> Pour ric - > optimisation tableau !
        tablo = Range(.Cells(2, 42), .Cells(DernLigne, 42))
        tabloTiret = tablo
        For Lig = 1 To UBound(tablo, 1)
            tabloTiret(Lig, 1) = UBound(Split(tablo(Lig, 1), "-"))
        Next
        .Cells(2, 42).Resize(UBound(tabloTiret, 1), 1) = WorksheetFunction.Transpose(tabloTiret)
        '   <------------- Gli73

(..)

Ok pour 20sec. vs 16sec.

Première re-optimisation depuis la version de ric (sans aller jusqu'au bout du code qu'il a écrit), "mes optimisations" sont encadrées de '------------> Gli73/ <------------ Gli73'

Sub Data_manquantes()
Dim DernLigne As Long, Lig As Long
Dim TabLig() As String
Dim Ws As Worksheet
Dim tablo
Dim i&, j&, k&

'   -------------> Gli73
Dim fileB   As Workbook
Dim tabloTiret
'   <------------- Gli73

    Application.ScreenUpdating = False

    c = Timer

    'Déclaration des Objets
    Set Ws = ThisWorkbook.Worksheets(1)
    With Ws

        ' Ajout des colonnes pour inclure les données manquantes
        .Range("AO1").Value = "Type de donnees de publication web a renseigner"
        .Range("AP1").Value = "Attributs manquants pour la publication"
        .Range("AQ1").Value = "Nombre d'attributs manquants"

        ' Recherche du fichier avec les données manquantes et ajout de celles-ci dans nouvel onglet sur 1er ficher

        Set fileB = Workbooks.Open("C:\Users\XXX\Documents\Suivi Pilotage\Data manquante rapport de pub.xlsx")
        '   -------------> Gli73
        With fileB
            .Sheets("Sheet1").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            .Close
        End With
        '   <------------- Gli73

        ' Intégration des nouvelles données dans les bons onglets
        '   -------------> Gli73
        '.Range("AO2").Formula = "=IFERROR(INDEX(Sheet1!C[-40]:C[-38],MATCH(FIXED(R[1]C[-39],0,1),Sheet1!C[-40],0),2),""Aucune"")"
        '.Range("AP2").Formula = "=IFERROR(INDEX(Sheet1!C[-41]:C[-39],MATCH(FIXED(R[1]C[-40],0,1),Sheet1!C[-41],0),3),""Aucun"")"
        '
        '' Faire descendre les formules dans les colonnes
        '
        'DernLigne = .Range("B" & .Rows.Count).End(xlUp).Row
        '.Range("AO2").AutoFill Destination:=.Range("AO2:AO" & DernLigne)
        '.Range("AP2").AutoFill Destination:=.Range("AP2:AP" & DernLigne)
        DernLigne = .Cells(Rows.Count, 2).End(xlUp).Row
        Range(.Cells(2, 41), .Cells(DernLigne, 41)).Formula = "=IFERROR(INDEX(Sheet1!C[-40]:C[-38],MATCH(FIXED(R[1]C[-39],0,1),Sheet1!C[-40],0),2),""Aucune"")"
        Range(.Cells(2, 42), .Cells(DernLigne, 42)).Formula = "=IFERROR(INDEX(Sheet1!C[-41]:C[-39],MATCH(FIXED(R[1]C[-40],0,1),Sheet1!C[-41],0),3),""Aucun"")"
        '   <------------- Gli73

        ' Compter le nombre d'attributs manquants
        ' Pour chaque ligne
        '   -------------> Gli73
        'For Lig = 2 To DernLigne
        '    ' Récupérer le tableau des tirets
        '    TabLig = Split(.Range("AP" & Lig), "-")
        '    ' Inscrire le nombre d'attributs manquants
        '    .Range("AQ" & Lig).Value = UBound(TabLig) & " attribut(s) manquant(s)"
        'Next Lig
        '   Gli73 -> Pour ric - > optimisation tableau !
        tablo = Range(.Cells(2, 42), .Cells(DernLigne, 42))
        tabloTiret = tablo
        For Lig = 1 To UBound(tablo, 1)
            tabloTiret(Lig, 1) = UBound(Split(tablo(Lig, 1), "-"))
        Next
        .Cells(2, 42).Resize(UBound(tabloTiret, 1), 1) = WorksheetFunction.Transpose(tabloTiret)
        '   <------------- Gli73

Merci de ton aide juste un petit soucis, sur le tableau cela prend la place d'une colonne "AP" alors que ça devrait être renvoyé sur la colonne "AQ" en essayant de toucher moi même je vois qu'en changeant

'.Cells(2, 42).Resize(UBound(tabloTiret, 1), 1) = WorksheetFunction.Transpose(tabloTiret)

Par .Cells(2, 43).Resize(UBound(tabloTiret, 1), 1) = WorksheetFunction.Transpose(tabloTiret)

J'obtiens bien des 0 dans la bonne colonne mais par contre c'est toujours 0 alors que je devrais avoir des résultats :/ J'avoue être bloqué là

Merci à toi

(..)

C'est fort possible... moins qui donne les "bons conseils" et les "choses à ne jamais faire" j'ai écrit le code à la volée, et surtout sans le tester ! C'est pas bien ! pas bien du tout !

Retente en remplaçant WorksheetFunction.Transpose(tabloTiret) par simplement tabloTiret dans cette ligne :

.Cells(2, 42).Resize(UBound(tabloTiret, 1), 1) = WorksheetFunction.Transpose(tabloTiret)

Mais je ne suis pas certain que ça change !

(..)

C'est fort possible... moins qui donne les "bons conseils" et les "choses à ne jamais faire" j'ai écrit le code à la volée, et surtout sans le tester ! C'est pas bien ! pas bien du tout !

Retente en remplaçant WorksheetFunction.Transpose(tabloTiret) par simplement tabloTiret dans cette ligne :

.Cells(2, 42).Resize(UBound(tabloTiret, 1), 1) = WorksheetFunction.Transpose(tabloTiret)

Mais je ne suis pas certain que ça change !

Et bien écoute ça fonctionne

J'ai testé quasiment tout sauf ça j'avais hésité sans trop comprendre la formule mais bon comme quoi parfois faut suivre son instinct

Résultat : on passe de 16,2s à 15,4s plutôt très encourageant

Merci à toi et à Ric pour votre aide !! vous êtes au top !

Bonjour

C'est encourageant, en effet !

Je pense qu'il est possible de passer en dessous de la barre des 10 sec.

Bonjour

C'est encourageant, en effet !

Je pense qu'il est possible de passer en dessous de la barre des 10 sec.

Hello,

Je vais voir si j'arrive à trouver des petits tips avec vos différentes optimisations

Merci à vous

Rechercher des sujets similaires à "optimisation vba"