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

Staple1600 · 15 Février 2018

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)

Staple1600 · 21 Février 2018

Bonsoir job75

Dans le post#22 (mais sans doute n'étais-je pas explicite), je parlais d'insérer des lignes vides entre des blocs.

NB: L'opérateur de saisie mène la tâche de saisie selon des paramètres qui ne sont pas les miens et que je ne maîtrise pas.

Ce que je peux confirmer, c'est que le point de départ, c'est ce que j'explique dans le message#58

1) On part d'un tableau existant sur lequel on efface les Constantes (pour parler comme F5) à partir de la ligne 3

2) saisie des numéros de blocs en colonne A selon les besoins.

3) saisies des données dans les autres colonnes idoines

4) Vérification des calculs
(soit par bouton soit par procédure événementielle injection des formules issues de ce post, notamment tes propositions, job )

[aparté]
Je cherche en vain l'équivalent en utilisant un Array de la macro:Test du message#59
Quelqu'un pour éclairer ma lanterne?

J'en suis ici

Code:

sub test_b()
Dim t()
Dim Rng As Range, Plg As Range, NB_Num, i&, DerL&
NB_Num = InputBox("Nombre de blocs?", "Blocs", 5)
ReDim t(1 To NB_Num * 9)
For i = LBound(t) To UBound(t)
'c'est là que je coince
Next
[A2].Resize(Ubound(t)=t
End Sub

Staple1600 · 21 Février 2018

Re

J'ai testé avec : NlignesVides = 10
Mais dans ce cas, le message suivant apparaît

job75 · 21 Février 2018

Re,

Ce message apparaissait quand on supprimait des lignes qui venaient d'être ajoutées.

Pour l'éviter j'ai modifié les fichiers (2) et (2 bis) de mon post #57 avec en fin de macro :

Code:

With UsedRange: End With 'actualise les barres de défilement

A+

Staple1600 · 21 Février 2018

Re

Le message n’apparaît plus [OK]

On doit pouvoir insérer des lignes dans un bloc (au dessus ou au dessous de la ligne active)

Exemple:
Le bloc 1 (qui commence en A3) contient 5 lignes donc on a:
1
1
1
1
1
2
n
n

On a besoin d'insérer N lignes dans le bloc 1
Actuellement je ne peux pas insérer de ligne (avec Sélection Lignes, clic-droit Insertion)

Il faut aller en fin de colonne A et saisir 1 N fois (pour que le bloc 1 contienne le nombre de ligne nouvellement désiré)
Ou saisir 1 puis recopier vers le bas sur N cellules
La colonne est triée et il faut remonter pour continuer la saisie
(personnellement cela ne me perturbe pas)
mais pas sur que cela convienne à l'opérateur

eriiic · 22 Février 2018

Bonjour à tous,

annulé...
Je pensais avoir eu une idée plus simple mais finalement inapplicable ici.
eric

job75 · 22 Février 2018

Bonjour JM, eriiiic, le forum,

Puisque l'organisation en tableau Excel est sans intérêt on la supprime dans ce fichier (3) :

Code:

If ListObjects.Count Then ListObjects(1).TableStyle = "": ListObjects(1).Unlist 'si un tableau Excel a été créé

Cela permet d'alléger un peu le code.

Bonne journée.

job75 · 22 Février 2018

Re,

On peut faire un truc sympa en colorant les zones par des MFC :

Code:

Private Sub Worksheet_Calculate()
Dim PC As Range, pcr&, i&, h&
On Error Resume Next
Set PC = [PremiereCellule]: pcr = PC.Row
i = Application.Match(9 ^ 99, PC.EntireColumn): h = i - pcr - 1
'---correction si le tableau est trié sur une autre colonne que la 1ère colonne---
If Evaluate("SUM(-(" & PC(2).Resize(h).Address & "<" & PC(3).Resize(h).Address & "))") _
    And Evaluate("SUM(-(" & PC(2).Resize(h).Address & ">" & PC(3).Resize(h).Address & "))") _
        Or [U1].Offset(pcr, PC.Column - 1) = "" Then Worksheet_Change PC: Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NlignesVides&, PC As Range, pcr&, ColA As Range, i&, n&, MFC, zoneA&(), celBaseF1
Dim plageF1 As Range, plageF2 As Range, plageF3 As Range, pas%, a(), b(), plageMoy$, deb&, fin&, f$
NlignesVides = 10 'nombre de lignes vides sous le tableau, à adapter
Application.EnableEvents = False
On Error Resume Next
Set PC = [PremiereCellule]: pcr = PC.Row
'---interdit la suppression de "PremiereCellule" ou l'insertion de cellule/ligne sous les titres---
If pcr = 0 Or Rows(pcr + 1).SpecialCells(xlCellTypeAllFormatConditions).Count < 48 Then Application.Undo: GoTo 1 '48 à adapter
If Intersect(Target, [A:A,T:V,Y:AA,AD:AF,AI:AK,AN:AQ,AV:AV].Offset(, PC.Column - 1)) Is Nothing Then GoTo 1 'à adapter
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If ListObjects.Count Then ListObjects(1).TableStyle = "": ListObjects(1).Unlist 'si un tableau Excel a été créé
ShowAllData 'si la feuille est filtrée
'---détermination de ColA et épuration---
Set ColA = PC(2).Resize(Application.Match(9 ^ 99, PC.EntireColumn) - pcr)
ColA.EntireRow.Sort ColA, xlAscending, Header:=xlNo 'tri de sécurité
If ColA.Count > 1 Then ColA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'vides
If ColA.Count > 1 Then ColA.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete 'textes
'---mémorisation des lignes de début et de fin de zones en colonne A---
ReDim MFC(1 To pcr + ColA.Count, 1 To 1) 'tableau pour la MFC
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
    MFC(pcr + i, 1) = n Mod 2 'alternance
Next i
'---initialisation des cellules de base et des plages des formules, à adapter éventuellement---
celBaseF1 = Split([H1,J1,L1,N1,P1].Offset(pcr, PC.Column - 1).Address(0, 0), ",")
Set plageF1 = Intersect(ColA.EntireRow, [T:T].Offset(, PC.Column - 1))
Set plageF2 = Intersect(ColA.EntireRow, [U:U].Offset(, PC.Column - 1))
Set plageF3 = Intersect(ColA.EntireRow, [V:V].Offset(, PC.Column - 1))
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) & ")"
'---MFC et formats---
i = 0: i = Application.Match(9 ^ 99, PC.EntireColumn) 'dernière ligne du tableau
If i <= pcr Then i = pcr + 1: Rows(i) = "" 'au moins une ligne pour conserver les formats
ThisWorkbook.Names.Add "MFC", MFC 'nom défini
Rows(pcr + 1).AutoFill Rows(pcr + 1 & ":" & i), xlFillFormats 'copie les formats
'---traitement des lignes sous le tableau---
Rows(i + 1).Resize([V:V].Offset(, PC.Column - 1).Find("=13*/*", , xlFormulas, xlWhole, , xlPrevious).Row - i).Delete 'RAZ
n = 0: n = Rows(i + 1 & ":" & Rows.Count).Find("*", Cells(Rows.Count, 1), xlValues, , xlByRows, xlNext).Row
If n Then n = i + NlignesVides + 1 - n 'écart
If n > 0 Then Rows(i + 1).Resize(n).Insert: Rows(Rows.Count).Copy Rows(i + 1).Resize(n)
If n < 0 Then Rows(i + 1).Resize(-n).Delete
Application.Calculation = xlCalculationAutomatic
1 Application.EnableEvents = True
With UsedRange: End With 'actualise les barres de défilement
'---en cas d'oubli---
pcr = [PremiereCellule].Row
If pcr = 0 Then MsgBox "Vous devez créer le nom ""PremiereCellule"" !", 48
End Sub

Edit 1 : en nommant PremiereCellule la 1ère cellule du tableau on peut le déplacer où l'on veut.

Edit 2 : un test permet d'éviter la suppression de cette cellule ou celle des MFC sous les titres.

Fichier (4) + fichier de 520 lignes pour tester les durées d'exécution.

A+

job75 · 22 Février 2018

Re,

Si maintenant on veut pouvoir - temporairement - neutraliser les macros il suffit d'un bouton.

A+

job75 · 24 Février 2018

Bonjour JM,

J'ai plusieurs fois amélioré le code du post #67, c'est vrai qu'il y a du grain à moudre

Mais maintenant je crois avoir fait le tour de la question.

A+

Staple1600 · 25 Février 2018

Bonjour le fil, le forum

@job75
Je regarde tout* cela dés mon retour en ma demeure.
(*:ici PC sous XL2K3)

Merci encore pour ton implication dans ce fil.

Staple1600 · 25 Février 2018

Re,

Pour ce que je cherchais à faire dans l'aparté du post#59, j'ai solutionné la chose ainsi
(avec la fonction PLAFOND)
Pour ma gouverne et par curiosité , pourriez-vous m'indiquer une syntaxe qui n'utilise pas PLAFOND? (notamment dans la macro test_B)
Merci d'avance.

VB:

Sub test_A()
Dim Z$, X&, Y&, p As Range: [A3:A1600] = Empty: Application.ScreenUpdating = False
Z = InputBox("Nombre d'items Nombre de ligne?", "Préparation du tableau", "10 5"): X = Split(Z)(0): Y = Split(Z)(1)
Set p = [A3].Resize(X * Y): p = "=CEILING((ROW()-2)/" & CStr(Y) & ",1)": p.Value = p.Value
End Sub
Sub test_B()
Dim XY, X&, Y&, sPrompt$, t, i&: [A3:A1600] = ""
sPrompt = _
"Nombre d'items/Nombre de lignes?" & Chr(13) & Chr(13) & "(saisie valide : X/Y)"
XY = InputBox(sPrompt, "Préparation du tableau", "10/5")
X = Split(XY, "/")(0): Y = Split(XY, "/")(1): ReDim t(1 To X * Y)
With Application
    .ScreenUpdating = False
    For i = LBound(t) To UBound(t): t(i) = .Ceiling(i / Y, 1): Next
    [A3].Resize(UBound(t)) = .Transpose(t)
End With
End Sub
[code=vb]

job75 · 25 Février 2018

Bonsoir JM,

Ajout d'un bouton pour créer une nouvelle zone :

Code:

Dim NlignesVides& 'mémorise la variable

Sub CreerZone()
Dim PC As Range, NumZone, Nlig, i&
On Error Resume Next
Set PC = [PremiereCellule]
NumZone = Abs(Int(Val(InputBox("Numéro de zone :", "Créer une zone", Application.Max(PC.EntireColumn) + 1))))
If NumZone = 0 Then Exit Sub
Nlig = Int(Val(InputBox("Maximum 1000 lignes :", "Nombre de lignes", 10)))
If Nlig < 1 Or Nlig > 1000 Then Exit Sub
NlignesVides = Nlig
If CheckBox1 Then CheckBox1 = False Else Worksheet_Change PC 'pour décaler ce qui est sous le tableau
i = Application.Match(9 ^ 99, PC.EntireColumn) - PC.Row + 2
If i < 2 Then i = 2
NlignesVides = 0
PC(i).Resize(Nlig) = NumZone
End Sub

A+

job75 · 26 Février 2018

Bonjour JM, le forum,

Le fichier précédent ne peut pas être enregistré si le tableau dépasse la ligne 4090.

Car alors la formule du nom défini MFC dépasse la limite Excel de 8192 caractères.

Mais on peut aller au-delà en définissant la MFC à partir d'une plage dans une feuille auxiliaire (masquée) avec ce code dans la Worksheet_Change :

Code:

With Feuil2.[A:A] 'CodeName de la feuille auxiliaire masquée xlSheetVeryHidden
    .ClearContents 'RAZ
    .Resize(UBound(MFC)) = MFC
    .Name = "MFC" 'plage nommée
End With

Voyez ce fichier (2) avec un tableau de 10 000 lignes.

L'entrée d'un numéro de zone se fait chez moi en 2,1 secondes, pas mal pour un fichier de 2 Mo.

A+

eriiic · 27 Février 2018

Bonjour,

finalement est-ce que ça ne serait pas plus simple de les empêcher de modifier les formules ?
En protégeant la feuille ou en empêchant la sélection de ces cellules, et en complétant par un Application.Undo si une de ces cellules est touchée par un collé d'une plage.
eric

job75 · 27 Février 2018

Bonjour JM, eriiiic, le forum,

En fusionnant des cellules en ligne 1 je me suis rendu compte que la 1ère formule n'était plus correcte.

Pour y remédier j'ai modifié dans les 2 derniers fichiers :

Code:

'celBaseF1 = Split([H1,J1,L1,N1,P1].Offset(pcr, PC.Column - 1).Address(0, 0), ",") 'problème si cellules fusionnées
celBaseF1 = Split(Range(Replace("H1,J1,L1,N1,P1", 1, pcr + 1)).Offset(, PC.Column - 1).Address(0, 0), ",")

Fonctionne même si les cellules sont jointives (H1,I1,J1...).

@ eriiiic : tu n'as pas dû bien regarder mon code.

Protéger les cellules des formules n'apporterait rien, il me semble l'avoir dit.

La difficulté réside ici dans le fait d'entrer les bonnes formules dans les bonnes plages.

A+

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

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

eriiic

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

eriiic

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Discussions similaires