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
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
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.
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.
SpoilerSub 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
pour le chrono, combien de lignes dans "ta version" non allégée ?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 infos
pour le chrono, combien de lignes dans "ta version" non allégée ?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).
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 !
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.