Microsoft 365 Transfert de données

[GClaire]

Hello la communauté.

Toujours dans l'aide pour un ami qui fait des Quizz.

Je souhaite faire l'export (Bouton export choix) des données de la feuille "Base" a "Choix", si il y a des numéros (1 a 7) dans la colonne "O", avec un test du nombre de questions par numéro (Il sera entrée en dure dans une variable).

Comme je l'ai fait pour une autre partie de cette appli :

'On Renseigne le Nombre de choix par thèmes
NbChoixTheme1 = 10
NbChoixTheme2 = 10
NbChoixTheme3 = 10
NbChoixTheme4 = 10
NbChoixTheme5 = 10
NbChoixTheme6 = 15
'NbChoixTheme7 = 0
'NbChoixTheme8 = 0


Dans le module : Mdl_ExportChoix

Sub ExportChoix()
  
Dim wsBase As Worksheet
Dim wsChoix As Worksheet
Dim lastRowBase As Long, lastRowChoix As Long, i As Long, j As Long

' Spécifier les feuilles de calcul
Set wsBase = ThisWorkbook.Sheets("Base")
Set wsChoix = ThisWorkbook.Sheets("Choix")

' Trouver la dernière ligne dans la colonne O de la feuille "Base"
lastRowBase = wsBase.Cells(wsBase.Rows.count, "O").End(xlUp).Row

' Supprimer les lignes de A5 à la dernière ligne dans les colonnes A à AB
wsChoix.Range("A5:AB" & lastRowBase).Delete

' Réinitialiser le compteur de lignes pour la feuille "Choix"
lastRowChoix = 5

' Parcourir la colonne "O" à partir de la ligne 5 jusqu'à la dernière ligne de la feuille "Base"
For i = 5 To lastRowBase
' Vérifier si la valeur dans la colonne "O" est égale à 0, 1, 2, 3, 4, 5 ou 6
    If wsBase.Cells(i, "O").Value >= "1" And wsBase.Cells(i, "O").Value <= "7" Then
        ' Copier la plage de cellules de A:O dans la feuille "Base" vers la feuille "Choix"
        wsBase.Range("A" & i & ":O" & i).Copy Destination:=wsChoix.Range("A" & lastRowChoix)
        lastRowChoix = lastRowChoix + 1 ' Incrémenter le compteur de lignes pour la feuille "Choix"
    End If
Next i

' Si aucune ligne n'est copiée, afficher un message
If lastRowChoix = 5 Then
    MsgBox "Aucun choix n'a été effectué.", vbInformation
Else
    MsgBox "Export de " & (lastRowChoix - 5) & " choix effectué.", vbInformation
End If

AppliquerFormule_Choix

End Sub

Le soucis premier est le temps d'exécution (Environ 30 secondes) et a la base la feuille "Base" a Mini 10300 Lignes.

Y'a t'il moyen d'optimiser cela?

Et je souhaiterai que les formules des plages en oranges (Qui ne bougeront jamais), c'est figé comme cela, s'exportent aussi, car la je me retrouve avec des "ref" perdues?
Je sais qu'il y'a des traitements lourdingue avec la feuille "Base", mais je ne sais pas faire autrement.
Sur ces deux procédures dans :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    AppliquerCouleur
  
    ColoriserSelonK_Base
End Sub

Y'a t'il moyen d'optimiser cela?

Je vous remercie par avance pour toute l'aide apportée.

Bonne soirée.

G'Claire

 

[GClaire]

Hello

J'ai tenté cela, mais en vain.

Sub ExportChoix()
    Dim wsBase As Worksheet
    Dim wsChoix As Worksheet
    Dim lastRowBase As Long, i As Long, j As Long, lastRowChoix As Long
 
    ' Spécifier la feuille de calcul
    Set wsChoix = ThisWorkbook.Sheets("Choix")
    ' Définir les feuilles de travail
    Set wsBase = ThisWorkbook.Sheets("Base")
    ' Trouver la dernière ligne de la colonne "O" de la feuille "Base"
    lastRowBase = wsBase.Cells(wsBase.Rows.Count, "O").End(xlUp).Row
 
    ' Trouver la dernière ligne dans la colonne A de la feuille "Choix"
    lastRowChoix = wsChoix.Cells(wsChoix.Rows.Count, "A").End(xlUp).Row
 
    ' Supprimer les lignes de A5 à la dernière ligne dans les colonnes A à AB de la feuille "Choix"
    wsChoix.Range("A5:AB" & lastRowChoix).Delete
 
    ' Réinitialiser le compteur de lignes pour la feuille "Choix"
    lastRowChoix = 5
 
 
    ' Parcourir la colonne "O" à partir de la ligne 1 jusqu'à la dernière ligne
    For i = 5 To lastRowBase
        ' Vérifier si la valeur dans la colonne "O" est égale à 1, 2, 3, 4, 5, 6 ou 7
        If wsBase.Cells(i, "O").Value >= "1" And wsBase.Cells(i, "O").Value <= "7" Then
            ' Filtrer les cellules visibles dans la plage de cellules "A:O" de la ligne i de la feuille "Base"
            wsBase.Rows(i).Columns("A:O").SpecialCells(xlCellTypeVisible).Copy Destination:=wsChoix.Cells(lastRowChoix, 1)
            lastRowChoix = lastRowChoix + 1
        End If
    Next i
 
    ' Si aucune ligne n'est copiée, afficher un message
    If lastRowChoix = 0 Then
        MsgBox "Aucun choix n'a été effectué.", vbInformation
    Else
        MsgBox "Export de " & lastRowChoix - 5 & " choix effectué.", vbInformation
    End If
 
AppliquerFormule_Choix
 
End Sub

Le code va un peu plus vite en éxécution, mais ne règle pas le soucis.

Une idée?

Merci et bonne journée, G'Claire

 

[sylvanu]

Bonjour Gclaire,
Sur mon PC et ma PJ je suis passé de 8.7s à 0.15s .... si je n'ai rien oublié. Avec :

Sub ExportChoix()
Dim DL1%, DL2%, DL%, Tablo, r, Formule$
Application.ScreenUpdating = False
Application.EnableEvents = False
With Sheets("Base")
    DL1 = .[A100000].End(xlUp).Row
    Tablo = .Range("A5:P" & DL1)
End With
With Sheets("Choix")
    DL = 1 + .[A100000].End(xlUp).Row
    .Range("A5:Q" & DL).ClearContents
    .Range("A5:Q" & DL).Borders.LineStyle = xlNone
    .Range("A5:Q" & DL).Interior.Color = xlNone
    .[A5].Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo
    DL = .[A100000].End(xlUp).Row
    Formule = "=SI(ET(O5>=1;O5<=6);0;CAR(1))"
    Set r = .Range("Q5:Q" & DL)
    r.FormulaLocal = Formule
    r.EntireRow.Sort .Cells, xlDescending           ' Tri pour regrouper et accélérer
    r.SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete  ' Suppression des lignes concernées
    .Range("A5:P" & DL).Sort Key1:=.[O5], Order1:=xlAscending, Header:=xlNo
    .[Q:Q].ClearContents
    DL = .[A100000].End(xlUp).Row
    .Range("A5:P" & DL).Borders.Weight = xlThin
End With
If [A5] = "" Then
    MsgBox "Aucun choix n'a été effectué.", vbInformation
Else
    MsgBox "Export de " & (DL - 5) & " choix effectué.", vbInformation
End If
Application.EnableEvents = True
End Sub

Pour être très rapide il faut éviter de lire et écrire dans les cellules, mieux vaut passer par un array.

La macro AppliquerCouleur invalidée dans Worksheet_SelectionChange, et remplacée par 2 MFC :

Col. A et J :  =$P1="x"
Col. B à E  :  =B$3=$H1

( Deux MFC sont beaucoup plus rapides qu'une macro telle que AppliquerCouleur )

 

[GClaire]

Bonjour sylvanu, le fofo

Merci, je regarde tout cela.

Bonne fin d'aprés-midi

G'Claire

 

[GClaire]

Hello Sylvanu, le fofo

Dans l'ensemble je dirais que c'est très bon.

Il est vrai que je ne pense jamais a ces MFC, pourtant très pratiques.

J'ai donc intégré cela dans mon fichier, fais deux trois ajouts et supprimé les trucs qui ne servaient plus.

Fichier plus allégé.

Merci encore pour l'aide apporté.

Bonne soirée

G'Claire

 

[GClaire]

Re Sylvanu, le fofo

La macro AppliquerCouleur invalidée dans Worksheet_SelectionChange, et remplacée par 2 MFC :
Code:
Col. A et J : =$P1="x"
Col. B à E : =B$3=$H1
( Deux MFC sont beaucoup plus rapides qu'une macro telle que AppliquerCouleur )

J'ai donc crée ces deux MFC

Autant celle de la croix se mette bien a jour quand je rajoute ou supprime un "X" ou "x" a priori cela ne fait aucune différant les majuscules et minuscules.

Autant la seconde cela ne fonctionne pas, je pense que cela prends en compte la colonne, alors que je souhaite que cela prenne en compte la lettre de la réponse

J'ai te,té cela :

=ET(B5=$H5, C5=$H5, D5=$H5, E5=$H5)

mais pas glop, lol

Une idée?

Merci

Bonne journée

G'Claire

 

[sylvanu]

Bonjour Gclaire,
Avez vous testé ma PJ ? car elle marche.
Quand on fait "=B$3=$H1" on regarde si le contenu de la colonne en ligne 3 est égal à la ligne en colonne H. Par ex pour C8 cela ferait D$3=$H8.
Avez vous mis cette MFC en B5 avant de la valider ?

 

[GClaire]

CC

Merci pour la réponse rapide.

Je n'avais pas saisie qu'il fallait être sur la cellule puis valider la MFC

Je test de ce pas.

Merci

Bon week

G'Claire