[VBA] Préservation formules existantes (+identification adresse cellules)

Staple1600

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, le forum

Dans un classeur identique à ce que donne la macro datas, je cherche à créer une macro qui pourra réinjecter toutes formules (qui sont toutes en relation avec les valeurs en colonne A)

Voir ce petit exemple (avec deux formules)
VB: 
Sub insert_formules()
'////////////////////////////////////////
datas 'macro juste pour créer données de test
'///////////////////////////////////////
'macro pour insérer formules
Dim i As Byte, adr
adr = Array(1, 5, 10)
For i = 0 To UBound(adr)
Cells(adr(i), "D").FormulaArray = "=MIN(IF(R1C1:R15C1=RC1,R1C2:R15C2))"
'avec la formule ci-dessous
'comment recopier jusqu'à la dernière cellule avant le changement de valeur en colonne A
Cells(adr(i), "F").FormulaR1C1 = "=RC[-4]/R" & adr(i) & "C4"
'ce genre de problème d'identification de la dernière cellule à mettre dans les formules 
'se reproduira pour N formules présentes dans le classeur
Next
End Sub
Private Sub datas()
Cells.Clear
[A1] = 1: [A5] = 2: [A10] = 3: [B1] = 100: [B2] = 97
 With Range("A1:A15")
    .SpecialCells(xlCellTypeBlanks).Formula = "=A1"
    .Value = .Value
End With
[B1:B2].AutoFill Destination:=Range("B1:B15")
End Sub

Je cherche le meilleur moyen d'identifier le changement de valeur en colonne A pour pouvoir en seule macro "remettre" les formules initiales (qui seront donc en dur dans le code)

Le but c'est d'éviter au maximum les suppressions accidentelles de formules (la personne utilisant le classeur ne maîtrisant pas Excel)
 
Dernière édition:
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re,

J'ai un peu modifié la macro pour la rendre plus générale :
Code: 
Sub ReconstruireFormules()
Dim ColA As Range, i&, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range
Dim pas%, plageMoy$, deb&, fin&
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
Set ColA = Range("A3", Range("A" & Rows.Count).End(xlUp))
If ColA.Row < 3 Then Exit Sub 'si tableau vide
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
On Error Resume Next 'si aucune SpecialCell
ColA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'vides
ColA.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'textes
If ColA.Count = 0 Then Exit Sub
On Error GoTo 0
'---mémorisation des lignes de début et de fin de zones en colonne A---
For i = 1 To ColA.Count
    If ColA(i) <> ColA(i - 1) Then
        n = n + 1
        ReDim Preserve zoneA(1 To 2, 1 To n)
        zoneA(1, n) = i
    End If
    zoneA(2, n) = i
Next
'---initialisation des cellules de base et des plages des formules, à adapter éventuellement---
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T])
Set plageF2 = Intersect(ColA.EntireRow, [U:U])
Set plageF3 = Intersect(ColA.EntireRow, [V:V])
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
For i = 0 To UBound(celBaseF1)
    Set plageF1 = plageF1.Offset(, pas * Sgn(i))
    Set plageF2 = plageF2.Offset(, pas * Sgn(i)): plageF2 = ""
    Set plageF3 = plageF3.Offset(, pas * Sgn(i))
    plageMoy = plageMoy & "," & plageF3(1).Address(0, 0) 'concaténation des adresses
    plageF1 = "=" & celBaseF1(i) & "*" & plageF1(1, -1).Address(0, 0) & "+2*" & plageF1(1, 0).Address(0, 0)
    For n = 1 To UBound(zoneA, 2)
        deb = zoneA(1, n): fin = zoneA(2, n)
        plageF2(deb) = "=MIN(" & plageF1(deb).Address(0, 0) & ":" & plageF1(fin).Address(0, 0) & ")"
        plageF3(deb).Resize(fin - deb + 1) = "=13*" & plageF2(deb).Address(1, 0) & "/" & plageF1(deb).Address(0, 0)
Next n, i
'---dernières formules---
plageF3.Offset(, 1) = "=AVERAGE(" & Mid(plageMoy, 2) & ")"
plageF3.Offset(, 6) = "=SUM(" & plageF3(1, 2).Resize(, 5).Address(0, 0) & ")"
End Sub
A+
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

@job75
On s'est pas mal compris

Je voulais parlais de l'idée de placer toutes les formules d'une feuille active dans un Array
pour ensuite les restituer
(voir message#30)

Je voulais dire comme tu n'as pas émis de commentaire dessus,
je suppose par conséquent c'est une idée à oublier, non ?
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

@job75
Merci d'avoir éclairer ma lanterne.

NB: Il ne s'agissait pas de répondre à tous les messages (aucun xldnaute ne le fait)
J’émettais juste une hypothèse dans mon fil en espérant que toi ou ceux qui s’y intéressent infirme ou développe cette piste.

Même si ici cette piste (formules dans un Array) n'est pas utile, je cherche toujours (pour ma gouverne) comment restituer le contenu de l'Array sans passer par la dernière boucle.

Merci à ceux qui m'indiqueront comme faire (ou pas) ;)
 
Vote positif 0 Vote négatif
eriiic

eriiic

XLDnaute Barbatruc
Re,

j'ai du mal à imaginer comment le faire sans boucle.
Mais quitte à enregistrer les formules quelque part je le ferais dans une feuille masquée plutôt qu'en dur dans la macro. Ca simplifierait considérablement le code, et une éventuelle évolution.
eric
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Bonsoir eriiiic

Merci de ta réponse
J'avais aussi pensé à dupliquer la feuille originale puis à la masquer
Mais si jamais la feuille est modifiée (ajout de ligne ou de colonne) et que je réinjecte les formules à partir de la feuille masquée, ce sera le souk, non.?

Pour le moment je vais tester avec la macro de job75 et voir aussi ce que cela donne à l'usage en protégeant la feuille sur le PC de l'utilisateur final.

Sinon pour mon histoire d'Array, je voulais tenter un truc du genre
VB: 
Sub a()' test OK
Dim t
Range("A1:B5") = "=ROW()*COLUMN()"
Range("C1:C5") = "=ROW()*COLUMN()^2"
t = Range("A1:C5").Formula
Cells.Clear
Range("A1:C5") = t
End Sub
Mais comme ceci cela ne fonctionne évidemment pas
VB: 
Sub test_Arrays_Formules_pasOK()
Dim x&, i&, t(), c As Range
Cells.Clear
[A1] = "=TODAY()": [C3] = "=ROW()": [E5] = "=COLUMN()": [H7] = "=PI()"
x = ActiveSheet.UsedRange.SpecialCells(-4123, 23).Count
adrss = ActiveSheet.UsedRange.SpecialCells(-4123, 23).Address
ReDim t(1 To x): i = 1
For Each c In ActiveSheet.UsedRange.SpecialCells(-4123, 23)
t(i) = c.Formula
i = i + 1
Next
Cells.Clear
MsgBox t(3) 'pour test
Range(adrss) = t
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour JM, le forum,

Voici une solution beaucoup plus rapide car elle utilise 2 tableaux VBA auxiliaires a et b :
Code: 
Sub ReconstruireFormulesRapidement()
Dim ColA As Range, i&, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range
Dim pas%, a(), b(), plageMoy$, deb&, fin&, f$
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
Set ColA = Range("A3", Range("A" & Rows.Count).End(xlUp))
If ColA.Row < 3 Then Exit Sub 'si tableau vide
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
On Error Resume Next 'si aucune SpecialCell
ColA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'vides
ColA.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'textes
If ColA.Count = 0 Then Exit Sub
On Error GoTo 0
Application.Calculation = xlCalculationManual
'---mémorisation des lignes de début et de fin de zones en colonne A---
For i = 1 To ColA.Count
    If ColA(i) <> ColA(i - 1) Then
        n = n + 1
        ReDim Preserve zoneA(1 To 2, 1 To n)
        zoneA(1, n) = i
    End If
    zoneA(2, n) = i
Next i
'---initialisation des cellules de base et des plages des formules, à adapter éventuellement---
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T])
Set plageF2 = Intersect(ColA.EntireRow, [U:U])
Set plageF3 = Intersect(ColA.EntireRow, [V:V])
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
ReDim a(1 To ColA.Count, 1 To 1): b = a '2 tableaux auxiliaires pour accélérer
For i = 0 To UBound(celBaseF1)
    Set plageF1 = plageF1.Offset(, pas * Sgn(i))
    Set plageF2 = plageF2.Offset(, pas * Sgn(i))
    Set plageF3 = plageF3.Offset(, pas * Sgn(i))
    plageMoy = plageMoy & "," & plageF3(1).Address(0, 0) 'concaténation des adresses
    plageF1 = "=" & celBaseF1(i) & "*" & plageF1(1, -1).Address(0, 0) & "+2*" & plageF1(1, 0).Address(0, 0)
    For n = 1 To UBound(zoneA, 2)
        deb = zoneA(1, n): fin = zoneA(2, n)
        a(deb, 1) = "=MIN(" & plageF1(deb).Address(0, 0) & ":" & plageF1(fin).Address(0, 0) & ")"
        f = "=13*" & plageF2(deb).Address(1, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb)) _
            & "/" & plageF1(deb).Address(0, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb))
        For deb = deb To fin
            b(deb, 1) = f
    Next deb, n
    plageF2 = a: plageF3 = b 'restitution
Next i
'---dernières formules---
plageF3.Offset(, 1) = "=AVERAGE(" & Mid(plageMoy, 2) & ")"
plageF3.Offset(, 6) = "=SUM(" & plageF3(1, 2).Resize(, 5).Address(0, 0) & ")"
Application.Calculation = xlCalculationAutomatic
End Sub
Sur 26 lignes elle s'exécute chez moi en 0,009 seconde au lieu de 0,15 seconde précédemment.

Elle est donc 16 fois plus rapide, ce sera bien utile sur un grand tableau.

PS : bien comprendre JM que ce sont les boucles imbriquées qui prennent du temps, il faut alors les traiter par des tableaux.

Bonne journée.
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour le fil, le forum, job75

@job75
Merci pour cette nouvelle version.
Je te dirai lundi soir ce que cela donne sur le tableau original.

Sinon concernant ton code, je cherche à comprendre cette syntaxe
Set plageF1 = plageF1.Offset(, pas * Sgn(i))
Pourquoi l'emploi de Sgn?
Sgn(0) renvoie 0 ensuite i >0 donc Sgn(i) renvoie 1
Donc pour i=0 on aura plageF1.Offset(, 0), ce qui permet de ne pas décaler pour le 1er élément, c'est ça?
NB: Je crois avoir compris tout en rédigeant le message et avec la petite macro de test ci-dessous ;)

VB: 
Sub testSgn()
Dim ColA As Range, i&, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range
Dim pas%, a(), b(), plageMoy$, deb&, fin&, f$
Dim test$
Set ColA = Range("A3", Range("A" & Rows.Count).End(xlUp))
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T])
Set plageF2 = Intersect(ColA.EntireRow, [U:U])
Set plageF3 = Intersect(ColA.EntireRow, [V:V])
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
ReDim a(1 To ColA.Count, 1 To 1): b = a '2 tableaux auxiliaires pour accélérer
For i = 0 To UBound(celBaseF1)
    Set plageF1 = plageF1.Offset(, pas * Sgn(i))
    test = test & "(valeur de i:" & i & "), " & Chr(13) & plageF1.Address & Chr(13)
    Set plageF2 = plageF2.Offset(, pas * Sgn(i))
    test = test & plageF2.Address & Chr(13)
    Set plageF3 = plageF3.Offset(, pas * Sgn(i))
    test = test & plageF3.Address & Chr(13)
Next i
Debug.Print test
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour JM, le forum,

Avec un si petit fichier ma dernière macro s'exécutera en moins de 1/10ème de seconde.

Il est alors plus simple de placer dans le code de la feuille :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:A,T:V,Y:AA,AD:AF,AI:AK,AN:AQ,AV:AV]) Is Nothing Then Exit Sub 'à adapter
Dim i&, ColA As Range, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range
Dim pas%, a(), b(), plageMoy$, deb&, fin&, f$
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next 'si aucune SpecialCell
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
i = Range("A" & Rows.Count).End(xlUp).Row
Rows(IIf(i < 3, 3, i + 1) & ":" & Rows.Count).Delete 'RAZ en dessous
If i < 3 Then GoTo 1
'---détermination de ColA et épuration---
Set ColA = Range("A3.A" & i)
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
ColA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'vides
ColA.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'textes
If ColA.Count = 0 Then GoTo 1
'---mémorisation des lignes de début et de fin de zones en colonne A---
For i = 1 To ColA.Count
    If ColA(i) <> ColA(i - 1) Then
        n = n + 1
        ReDim Preserve zoneA(1 To 2, 1 To n)
        zoneA(1, n) = i
    End If
    zoneA(2, n) = i
Next i
'---initialisation des cellules de base et des plages des formules, à adapter éventuellement---
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T])
Set plageF2 = Intersect(ColA.EntireRow, [U:U])
Set plageF3 = Intersect(ColA.EntireRow, [V:V])
pas = 5 'décalage vers la droite
'---formules F1 F2 F3---
ReDim a(1 To ColA.Count, 1 To 1): b = a '2 tableaux auxiliaires pour accélérer
For i = 0 To UBound(celBaseF1)
    Set plageF1 = plageF1.Offset(, pas * Sgn(i))
    Set plageF2 = plageF2.Offset(, pas * Sgn(i))
    Set plageF3 = plageF3.Offset(, pas * Sgn(i))
    plageMoy = plageMoy & "," & plageF3(1).Address(0, 0) 'concaténation des adresses
    plageF1 = "=" & celBaseF1(i) & "*" & plageF1(1, -1).Address(0, 0) & "+2*" & plageF1(1, 0).Address(0, 0)
    For n = 1 To UBound(zoneA, 2)
        deb = zoneA(1, n): fin = zoneA(2, n)
        a(deb, 1) = "=MIN(" & plageF1(deb).Address(0, 0) & ":" & plageF1(fin).Address(0, 0) & ")"
        f = "=13*" & plageF2(deb).Address(1, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb)) _
            & "/" & plageF1(deb).Address(0, 0, ReferenceStyle:=xlR1C1, RelativeTo:=plageF3(deb))
        For deb = deb To fin
            b(deb, 1) = f
    Next deb, n
    plageF2 = a: plageF3 = b 'restitution
Next i
'---dernières formules---
plageF3.Offset(, 1) = "=AVERAGE(" & Mid(plageMoy, 2) & ")"
plageF3.Offset(, 6) = "=SUM(" & plageF3(1, 2).Resize(, 5).Address(0, 0) & ")"
1 Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
La macro s'exécute chaque fois que l'utilisateur modifie la colonne A ou des formules.

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Si l'utilisateur trie le tableau sur une autre colonne que A les formules des minima ne sont plus correctes.

Pour corriger le tri il suffit d'ajouter cette macro :
Code: 
Private Sub Worksheet_Calculate()
Dim i As Variant
i = Application.Match(9 ^ 99, [A:A])
'---correction si le tableau est trié sur une autre colonne que la colonne A---
If Val(CStr(i)) > 4 Then If Evaluate("SUM(-(A3:A" & i - 1 & "<A4:A" & i & "))") _
    And Evaluate("SUM(-(A3:A" & i - 1 & ">A4:A" & i & "))") Or [U3] = "" _
        Then Worksheet_Change [A3]: Application.ScreenUpdating = True
End Sub
A+
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, le forum, job75

@job75
Test OK de ton code sur le fichier original.

Après le tableau où restituer les formules, il y a des données (sans formules pour le moment) : commentaires, notes observations etc...

Donc, je vais voir comment faire pour circonscrire le code au seul tableau avec formules.

PS:je teste demain ta procédure événementielle.

Merci encore pour ce code VBA.
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

Z
  • Question
XL 2021 VBA Prélèvement d'une donnée si une valeur recherchée est identique
Réponses
3
Affichages
187
ZiM
Z
C
  • Résolu(e)
Microsoft 365 Amélioration Macro.
Réponses
7
Affichages
321
crazy
C
L
  • Question
Microsoft 365 TCD VBA SELECTION PLUSIEUR VALEUR
Réponses
3
Affichages
406
merinos
merinos
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
222
guiyom
G
L
  • Question
Microsoft 365 VBA sur outlook
Réponses
14
Affichages
645
lesoldat9
L
looky62
  • Question
Microsoft 365 Code VBA Recherche par mots clés
2
Réponses
16
Affichages
1 K
job75
job75
H
  • Question
XL 2016 Mettre des titres avec une mise en forme spécifique
Réponses
1
Affichages
284
vgendron
vgendron
M
  • Résolu(e)
XL 2013 Variables VBA avec cellules
Réponses
3
Affichages
439
Hasco
Hasco
M
  • Question
Microsoft 365 Joindre une copie de 2 feuilles Excel dans outlook
Réponses
0
Affichages
292
Mika07
M
O
  • Question
XL 2010 suppression fichiers excel vba
Réponses
9
Affichages
379
Oneida
Oneida

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 47 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 196
Messages
2 086 101
Membres
103 116
dernier inscrit
kutobi87