formule repétitive

ebac1

XLDnaute Nouveau
Bonjour,
J'ai une formule répétitive sur 20000 lignes, cela est trés lourd le fichier reste bloquer à chaque saisies de données, comment pourrais-je optimiser ces formules
Voir fichier exemple joint.
Merci d'avance pour votre aide
 

Pièces jointes

  • Classeur1.xlsx
    10.8 KB · Affichages: 25
Dernière édition:

job75

XLDnaute Barbatruc
Bonsoir à tous,

Très bon travail JHA.

Du coup je me suis lancé dans une gestion complète du tableau par VBA, c'est assez trapu.

Ces 2 macros sont placées dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :
Code:
Private Sub Worksheet_SelectionChange(ByVal R As Range)
Range("B2:C" & Rows.Count).Validation.Delete 'RAZ
Set R = ActiveCell
If R.Row = 1 Or Cells(R.Row, 1) = "" Then Exit Sub
If Not Cells(R.Row, 1) Like "####" Or Val(Right(Cells(R.Row, 1), 2))  = 0 Or Val(Right(Cells(R.Row, 1), 2)) > 12 _
    Then MsgBox "Année et/ou mois non valides !", 48: Exit Sub
Dim d As Object, dat As Date, sem As Byte, x$
If R.Column = 2 Then
    If R(1, 0) <> "" Then
        Set d = CreateObject("Scripting.Dictionary")
        For dat = DateSerial("20" & Left(R(1, 0), 2), Right(R(1, 0), 2), 1) To DateSerial("20" & Left(R(1, 0), 2), Right(R(1, 0) + 1, 2), 0)
            sem = Application.IsoWeekNum(dat)
            If Not d.exists(sem) Then d(sem) = "": x = x & "," & Format(sem, "\S00")
        Next
        R.Validation.Add xlValidateList, Formula1:=Mid(x, 2)
    End If
ElseIf R.Column = 3 Then
    If R(1, -1) <> "" And R(1, 0) <> "" Then
        For dat = DateSerial("20" & Left(R(1, -1), 2), Right(R(1, -1), 2), 1) To DateSerial("20" & Left(R(1, -1), 2), Right(R(1, -1) + 1, 2), 0)
            sem = Application.IsoWeekNum(dat)
            If Format(sem, "\S00") = R(1, 0) Then x = x & "," & Application.Proper(Format(dat, "ddd dd/mm/yyyy"))
        Next
        R.Validation.Add xlValidateList, Formula1:=Mid(x, 2)
    End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a As Range
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next
With ListObjects(1).DataBodyRange 'tableau Excel
    For Each a In Intersect(Target, .Columns(1)).Areas
        a.Offset(, 1).Resize(, 2) = "" 'effacements en colonnes B et C
    Next
    For Each a In Intersect(Target, .Columns(2)).Areas
        a.Offset(, 1) = "" 'effacements en colonne C
    Next
    If Application.CountBlank(.Columns(1)) Then
        .Sort .Columns(4), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
        Intersect(.SpecialCells(xlCellTypeBlanks).EntireRow, .Cells).Delete xlUp
    End If
    If .Cells(1, 4).Formula <> "=IFERROR(--RIGHT(C2,10),"""")" Then .Cells(1, 4) = "=IFERROR(--RIGHT(C2,10),"""")"
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
Fichier joint.

Edit : le fichier (1 bis) est plus léger, il n'y a que 3 colonnes.

A+
 

Pièces jointes

  • Dates(1).xlsm
    30.8 KB · Affichages: 12
  • Dates(1 bis).xlsm
    31.2 KB · Affichages: 5
Dernière édition:

ebac1

XLDnaute Nouveau
Bonjour,
Merci pour votre aide, dans mon fichier je ne peux pas modifier le mois, la semaine, le jour oui, mais dans le format imposé, car tout ceux-ci est liées à une base de données qui génére un planning automatique sur plusieurs PC
 

job75

XLDnaute Barbatruc
Bonjour ebac1, le forum,

C'est vrai qu'on ne s'est pas jusqu'ici préoccupé du problème posé au post #1.

J'ai regardé de près la question : les formules des dates en colonne D ne sont pas lourdes du tout.

Mais on ne pouvait même pas copier-coller la plage A2:A18 sur 20 000 lignes !

J'en ai conclu que votre fichier était vérolé.

J'ai donc reconstruit le tableau A2: D18 sur un classeur vierge en entrant les données une par une sans copier-coller.

Ensuite j'ai pu le recopier sans problème sur 20 400 lignes, voyez le fichier joint qui maintenant va bien.

A+
 

Pièces jointes

  • Classeur 20 400 lignes(1).xlsx
    483.7 KB · Affichages: 6

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 917
Membres
101 839
dernier inscrit
laurentEstrées