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

[Staple1600]

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)

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)

 

[Staple1600]

Bonsoir eriiiic

Comme tu l'as précisé, je suis très fatigué
Et je ne vois pas concrétement là immédiatement comment utilisé NB.SI pour cette histoire d'identification de début et de fin de bloc

Le code de job75 (message#6) semble convenir
Je le testerai lundi au boulot

Non, il n'y pas de doublons

Le fichier fonctionne selon ce principe
Lot
1 ITEM1 data data dataaa
1 ITEM2 data dataa dataaa
2 ITEM1 data dataa dataaa
2 ITEM2 data dataa dataaa
2 ITEM3 ...
N ITEMN data dataa dataaa

On peut avoir le même ITEM sur N lots
(et dans ce cas, les données seront saisies N fois, par contre les formules seront toujours agencées de la même façon
Certaines devront être sur la ligne de début de lot
D'autres seront recopiées du début à la fin d'un lot
Certaines auront des références dollarisées et d'autres pas.

Les données saisies changent selon les lots et les items mais les formules ne changent pas.

NB: Je n'ai pas accès à XLD au boulot (pour cause de filtrage Web efficace)
Ce qui explique je ne poste qu'en dehors des horaires de bureau.

 

[eriiic]

J'imaginais un truc comme ça:

Sub test()
    Dim ligDeb As Long, nblig As Long
    ligDeb = 1: lot = Cells(ligDeb, 1)
    For ligDeb = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        nblig = Application.CountIf(Columns(1), Cells(ligDeb, 1)) ' taille
        Cells(ligDeb, 3).Resize(nblig).Formula = "=Min(" & Cells(ligDeb, 2).Resize(nblig).Address & ")+" & Cells(ligDeb, 2).Address(False, True) ' formule bidon
        ligDeb = ligDeb + nblig - 1
    Next ligDeb
End Sub

lots regroupés dans A bien sûr.

A dire vrai j'ai dû rater qq chose.
Je ne vois pas dans tes formules une qui changerait selon les lots et qui justifierait ce besoin. Elles ont l'air d'être identiques sur toute la colonne.
Je suis fatigué aussi, un déménagement... ;-)
eric

 

[Staple1600]

Re

Un exemple de changement
(j'ai repris une formule simple pour trouver le MIN)
NB: En me basant sur les donnés créés par la macro valeurs
U3=>=MIN(S3:S6)
U7=>=MIN(S7:S10)
U12=>=MIN(S12:S15)
U19=>=MIN(S19:S22)

 

[Staple1600]

Re

eriiiic
En modifiant ta formule comme suit, les formules MIN sont mises au bon endroit

Sub test_ok()
Dim ligDeb&, nblig&
ligDeb = 3: lot = Cells(ligDeb, 3)
For ligDeb = 3 To Cells(Rows.Count, 1).End(xlUp).Row
nblig = Application.CountIf(Columns(1), Cells(ligDeb, 1))
Cells(ligDeb, "U").Formula = "=MIN(" & Cells(ligDeb, "T").Resize(nblig).Address & ")"
ligDeb = ligDeb + nblig - 1
Next ligDeb
End Sub

 

[job75]

Bonjour JM, eriiiic, zebanx, le forum,

JM remplace ta macro formules par celle-ci :

Sub ReconstruireFormules()
Dim ColA As Range, i&, n&, zoneA&(), celBaseF1, plageF1 As Range, plageF2 As Range, plageF3 As Range, deb&, fin&
Set ColA = Range("A3", Range("A" & Rows.Count).End(xlUp))
If ColA.Row < 3 Then Exit Sub 'si tableau vide
Application.ScreenUpdating = False
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
'---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---
celBaseF1 = Array("H3", "J3", "L3", "N3", "P3") 'adresses (sans signe $)
Set plageF1 = Intersect(ColA.EntireRow, [T:T]).Offset(, -5)
Set plageF2 = Intersect(ColA.EntireRow, [U:U]).Offset(, -5)
Set plageF3 = Intersect(ColA.EntireRow, [V:V]).Offset(, -5)
'---formules F1 F2 F3---
For i = 1 To 5
    Set plageF1 = plageF1.Offset(, 5)
    Set plageF2 = plageF2.Offset(, 5): plageF2 = ""
    Set plageF3 = plageF3.Offset(, 5)
    plageF1 = "=" & celBaseF1(i - 1) & "*" & 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---
Intersect(ColA.EntireRow, [AQ:AQ]) = "=AVERAGE(V3,AA3,AF3,AK3,AP3)"
Intersect(ColA.EntireRow, [AV:AV]) = "=SUM(AQ3:AU3)"
End Sub

Elle peut paraître un peu longue mais il n'y a que 5 lignes pour entrer les formules.

Edit 1 : pour alléger le code j'ai introduit les variables deb et fin mais ça ne change pas la durée d'exécution.

Edit 2 : j'ai défini celBaseF1 par un Array, c'est mieux qu'un Range.

Bon week-end.

 

[job75]

Re,

Sur l'exemple (26 lignes) la macro précédente s'exécute chez moi en 0,17 seconde.

Ou en 0,15 seconde avec Application.ScreenUpdating = False

La durée est proportionnelle au nombre de lignes et au nombre de zones.

A+

 

[Staple1600]

Bonjour le fil, le forum

@job75
Merci pour ce bel ouvrage
Je teste cela en situation réelle lundi matin.

Maintenant, il me reste à déterminer toutes "erreurs de manipulations" ou de restructuration du fichier
Je vois déjà un écueil possible
Ils leur arrivent de scinder le tableau en ajoutant une ligne vide ou deux, ce qui donnerait

Situation "normale"
1
1
2
2
3
3
3

Situation "altérée"
1
1
2
2

INTITULE X
3
3
3


PS: De mémoire, c'est coton d'inhiber par VBA l'insertion de lignes/colonnes- couper/coller etc... non ?
Je vais peut-être quand même tenter l'approche "Protection de la feuille" en plus du code VBA pour reconstruire les formules

 

[zebanx]

Bonjour JM, eriiiic, zebanx, le forum,

Bravo à Job75 pour cette énième proposition (#20)

Une petite question concernant un chiffre sur le code #6 :
Intersect(b.EntireRow, Columns("F")) = "=" & b(1).Address(0, 0) & "/" & c.Address(1, 0)

A quoi correspond ce chiffre svp ? (ie : 0 fait bugger le code).

Je te remercie par avance pour ta précision.
Ce code vient compléter un fichier intersect (qui ne contient presque que tes codes !).

Bonne journée et bon testing à Staple1600 -)
zebanx

* et merci à Staple1600 pour FormulaArray que je ne connaissais pas

 

[Staple1600]

Bonjour zebanx

J'ai testé le code de job75 sur un fichier (presque vide)
J'avais juste mis des données en colonne A

Pas de bug chez moi (XL 2013)

EDITION: Désolé, je parlais du dernier code de job75
Je vais voir le code#6 de ce pas

 

[Staple1600]

Re

@zebanx
Avec le petit MSgBox qui va bien, c'est limpide, non ?

Sub insert_formules()
datas
Dim a As Range, b As Range, c As Range
For Each a In [A1:A15].SpecialCells(xlCellTypeBlanks).Areas
    a = a(0)
MsgBox "valeur de a: " & a.Address 'pour test
    Set b = Intersect(Union(a(0), a).EntireRow, Columns("B"))
    Set c = Intersect(a(0).EntireRow, Columns("D"))
    c = "=MIN(" & b.Address(0, 0) & ")"
MsgBox "valeur de b(1): " & b(1).Address(0, 0) ' pour test
    Intersect(b.EntireRow, Columns("F")) = "=" & b(1).Address(0, 0) & "/" & c.Address(1, 0)
Next
End Sub

 

[job75]

Re JM,

L'introduction de lignes "parasites" avec des vides ou des textes en colonne A n'est guère gênante puisqu'elles seront regroupées à la fin du tableau par le tri initial si en situation "normale" on a bien des nombres en colonne A.

Dans ce cas il est d'ailleurs facile de les supprimer après le tri :

Application.ScreenUpdating = False
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
On Error GoTo 0

A+

 

[Staple1600]

Re

Effectivement, on sauve les meubles

Sub datas_Test()
Cells.Clear
[A3:A5] = 1: [A6:A9] = 2: [A10:A14] = 3: [A15:A20] = 4
[B3:B20].FormulaLocal = "=CAR(64+A3)&LIGNE()"
[D3:D20] = "=(1600*(ROW()-2))/40"
With ActiveSheet.UsedRange
.Value = .Value
End With
ReconstruireFormules
End Sub
Sub AlterationParLusagerTemeraire()
Rows("15:17").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
[A18] = "INTITULE1": [A18].AutoFill Range("A18:D18"), 0
ReconstruireFormules
End Sub

Spoiler: Reconstruire v2

Sub ReconstruireFormules()
Dim ColA As Range, i&, n&, zoneA&(), celBaseF1 As Range, plageF1 As Range, plageF2 As Range, plageF3 As Range, deb&, fin&
Set ColA = Range("A3", Range("A" & Rows.Count).End(xlUp))
If ColA.Row < 3 Then Exit Sub 'si tableau vide

'Application.ScreenUpdating = False
'ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité

'''*addendum/////////////////////////////////////////////////////////////
Application.ScreenUpdating = False
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
On Error GoTo 0
'''* fin addendum////////////////////////////////////////////////////////

'---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---
Set celBaseF1 = [H3,J3,L3,N3,P3]
Set plageF1 = Intersect(ColA.EntireRow, [T:T]).Offset(, -5)
Set plageF2 = Intersect(ColA.EntireRow, [U:U]).Offset(, -5)
Set plageF3 = Intersect(ColA.EntireRow, [V:V]).Offset(, -5)
'---formules F1 F2 F3---
For i = 1 To 5
    Set plageF1 = plageF1.Offset(, 5)
    Set plageF2 = plageF2.Offset(, 5): plageF2 = ""
    Set plageF3 = plageF3.Offset(, 5)
    plageF1 = "=" & celBaseF1.Areas(i).Address(0, 0) & "*" & 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---
Intersect(ColA.EntireRow, [AQ:AQ]) = "=AVERAGE(V3,AA3,AF3,AK3,AP3)"
Intersect(ColA.EntireRow, [AV:AV]) = "=SUM(AQ3:AU3)"
End Sub

 

[zebanx]

Re
Sub AlterationParLusagerTemeraire()
Rows("15:17").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
[A18] = "INTITULE1": [A18].AutoFill Range("A1818"), 0
ReconstruireFormules
End Sub[/code]

Oseras-tu le laisser tel quel ?
Tu me diras qu'aller pour quelques collaborateurs dans l'éditeur de VBA (suivant présentation du #1) ça serait déjà du domaine de l'exceptionnel, pourquoi pas...

Ou le renommer ("APLT").
Au moins ça n'apparaitra pas par le ctrl+f8 (là encore peut-être un domaine strictement réservé avec passage systématique, indispensable, par boutons pour certains).

 

[Staple1600]

Re

L'usager en question n'a pas besoin de macro pour passer en mode Altération
Un mésusage du clavier et une souris trop prompte à réagir suffise

 

[Staple1600]

Re

@job75
Puisque dans ton Edit 2 (du 17/02 à 11:22), tu parles Array
J'étais parti sur cette piste (pour varier les plaisirs et par curiosité )

Sub test_Arrays_Formules()
Dim x&, i&, t(), c As Range
Cells.Clear
[A1] = "=TODAY()": [C3] = "=ROW()": [E5] = "=COLUMN()": [H7] = "=PI()"
x = ActiveSheet.UsedRange.SpecialCells(-4123, 23).Count
ReDim t(1 To x, 2): i = 1
For Each c In ActiveSheet.UsedRange.SpecialCells(-4123, 23)
t(i, 1) = c.Address: t(i, 2) = c.Formula
test = test & t(i, 1) & "|" & t(i, 2) & Chr(13)
i = i + 1
Next
Cells.Clear
MsgBox test
For j = LBound(t, 1) To UBound(t, 1)
Range(t(j, 1)).Formula = t(j, 2)
Next
End Sub

Je sèche sur le moyen de restituer les formules sans passer par une seconde boucle.

NB: Je ne sais si c'est une solution à envisager sur un classeur contenant de nombreuses formules.
Si c'est une fausse piste, j'utiliserai ta macro ReconstruireFormules