[VBA] Calcul surface selon valeurs cellules
Bonsoir,
J'ai une grosse modification à apporter à mon document, pour laquelle je ne sais pas comment m'y prendre.
Fonctionnement de mon document :
Première feuille : Base de données
Feuille 2 ['B'] : Récupération des infos de la feuille 1 pour générer un tableau.
Feuille 3 [C] : Indication manuelle du nombre d'impacts qui va engendrer la création d'autant de lignes qu'il n'y a d'impact, pour chacune des lignes originelles, puis fusion des cellules des colonnes [A : E] et [J : M]. De cette manière, il n'y a un saut de ligne que pour les colonnes [F : I].
Lorsque j'ai 1 impact, j'ai su faire en sorte que dans la colonne F, un "1" s'affiche, suivi par la surface concernée impactée.
Mais, il faut que ce fonctionnement s'applique également pour 2, 3 , 4 etc. impacts (jusqu'à 10 (et si on peut ne pas mettre de limite c'est mieux).
Il faudrait alors que pour chaque ligne créée dans la colonne F, les cellules se remplissent automatiquement avec le n° de l'impact (1, 2, 3, 4, etc.) et avec la surface impactée.
Cette surface impactée est calculée comme suit :
- Feuille 1, dans la colonne [AS] est indiquée une valeur.
- Cette valeur c'est la surface occupée par chaque entité (colonne [AH])
- Pour chacune de ces entités est indiqué un numéro d'impact (colonne [AT]) : Impact 1, Impact 2, Impact 3, etc.
Avec 1 impact, j'ai trouvé la démarche à suivre (tant bien que mal... mon code est disponible et vous allez pas aimer) ; en revanche, pour plus d'1 impact, je ne sais pas comment m'y prendre...
Vous auriez une idée ?
J'espère que c'est je suis assez explicite car c'est pas évident ! Autrement, je m'y reprendrai pour mieux décrire ce que je cherche à faire.
Merci de votre attention,
Bonne fin de journée !
A plus tard.
Bonsoir,
Pour simplifier les tâches, mon document créé désormais un nombre de ligne équivalent au nombre d'impacts précisés.
(Pour le moment ça marche sur le calcul du nombre de valeurs uniques présentes dans la feuille [A] colonne [AT].
Pour résumer ; voici les opérations réalisées par mon document :
Définition des variables, remplissages des premières colonnes de la feuille 2 ['B'] plus quelques traitements.
Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim rng As Range, Cell As Range, rng2 As Range, Cell2 As Range, rng3 As Range, Cell3 As Range
Dim n As Long, n2 As Long, g As Long, m As Long, o As Long
Dim n3 As Long, n4 As Long, n4b As Long, n5 As Long, n6 As Long, lrs As Long
Dim nn3, nn4, nn4b As Long
Application.ScreenUpdating = False
'initialisation des variables
Set ws = Worksheets("A")
Set ws2 = Worksheets("B")
Set ws3 = Worksheets("C")
'Set ws4 = Worksheets("D")
'Nettoyer le tableau avant calculs
lrs = ws.Cells(Rows.Count, 34).End(xlUp).Row
Range(Cells(3, 1), Cells(lrs, 26)).EntireRow.Delete
'Nettoyer le second tableau
ws3.Activate
suppression
ws2.Activate
With ws
'dernière ligne non vide de la colonne AH (34)
n = .Cells(.Rows.Count, 34).End(xlUp).Row 'AH
'plage à copier sans l'en-tête de colonne
Set rng = .Cells(2, 34).Resize(n - 1)
End With
With ws2
'dernière ligne non vide de la colonne B (2)
n2 = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
'cellule de destination de la copie de rng
Set Cell = .Cells(n2, 2)
End With
rng.Copy Destination:=Cell
With ws2
'dernière ligne non vide de la colonne B (2)
n2 = .Cells(.Rows.Count, 2).End(xlUp).Row 'B
'plage de cellules avec en-tête pour supprimer les doublons
Set rng = .Cells(2, 2).Resize(n2 - 1)
End With
'suppression des doublons
rng.RemoveDuplicates Columns:=1, Header:=xlYes
'Identifier la dernière ligne utilisée
g = ws2.Cells(Rows.Count, 2).End(xlUp).RowPuis, j'additionne les surfaces :
ws2.Range(Cells(3, 4), Cells(g, 4)).numberformat = "#,##0.00"" ha"""
ws2.Range(Cells(3, 4), Cells(g, 4)).FormulaR1C1 = _
"=IF(SUMIF(A!R2C34:R2500C34,'B'!RC[-2],A!R2C45:R2500C45)=0,"" - "",SUMIF(A!R2C34:R2500C34,'B'!RC[-2],A!R2C45:R2500C45))"Là, les pro du VBA voient probablement un souci ; l'utilisation d'une formule dans un code VBA (j'ai opté pour ce choix, ne sachant pas encore faire autrement).
La formule : SI(SOMME.SI(A!$AH$2:$AH$2500;B!B32;A!$AS$2:$AS$2500)=0;" - ";SOMME.SI(A!$AH$2:$AH$2500;B!B32;A!$AS$2:$AS$2500))
La première partie du code sert à dire : Si le résultat = "0" alors remplacer par "-".
Puis,
Je demande à faire la somme des surfaces (Feuille A ; colonne AS2 : AS2500), pour chaque valeur de la plage [Feuille A ; colonne AH] identique à la valeur indiquée dans la plage [Feuille B ; colonne A2 : A2500].
Si vous avez un code pour améliorer son fonctionnement et ne plus utiliser de formule je suis preneur.
'Recherche les données correspondantes
ws2.Range(Cells(3, 5), Cells(g, 5)).FormulaR1C1 = _
"=IF(INDEX(A!R2C1:R2500C47,MATCH(RC[-3],A!R2C34:R2500C34,0),30)=0,"" - "",INDEX(A!R2C1:R2500C47,MATCH(RC[-3],A!R2C34:R2500C34,0),30))"
ws2.Range(Cells(3, 6), Cells(g, 6)).FormulaR1C1 = _ "=IF(INDEX(A!R2C1:R2500C47,MATCH(RC[-4],A!R2C34:R2500C34,0),29)=0,""-"",INDEX(A!R2C1:R2500C47,MATCH(RC[-4],A!R2C34:R2500C34,0),29))"
ws2.Range(Cells(3, 7), Cells(g, 7)).FormulaR1C1 = _ "=IF(INDEX(A!R2C1:R2500C47,MATCH(RC[-5],A!R2C34:R2500C34,0),31)=0,""-"",INDEX(A!R2C1:R2500C47,MATCH(RC[-5],A!R2C34:R2500C34,0),31))"
ws2.Range(Cells(3, 8), Cells(g, 8)).FormulaR1C1 = _ "=IF(INDEX(A!R2C1:R2500C47,MATCH(RC[-6],A!R2C34:R2500C34,0),36)=0,""-"",INDEX(A!R2C1:R2500C47,MATCH(RC[-6],A!R2C34:R2500C34,0),36))"
ws2.Range(Cells(3, 9), Cells(g, 9)).FormulaR1C1 = _ "=IF(INDEX(A!R2C1:R2500C47,MATCH(RC[-7],A!R2C34:R2500C34,0),35)=0,""-"",INDEX(A!R2C1:R2500C47,MATCH(RC[-7],A!R2C34:R2500C34,0),35))"
ws2.Range(Cells(3, 10), Cells(g, 10)).FormulaR1C1 = _ "=IF(INDEX(A!R2C1:R2500C47,MATCH(RC[-8],A!R2C34:R2500C34,0),37)=0,""-"",INDEX(A!R2C1:R2500C47,MATCH(RC[-8],A!R2C34:R2500C34,0),37))"
Toutes ces formules permettent de remplir la plupart des colonnes de la Feuille B à parti des informations de la feuille A.
Voici ce que donne la première formule :
=SI(INDEX(A!$A$2:$AU$2500;EQUIV(B3;A!$AH$2:$AH$2500;0);30)=0;" - ";INDEX(A!$A$2:$AU$2500;EQUIV(B3;A!$AH$2:$AH$2500;0);30))
La première partie du code sert à dire : Si le résultat = "0" alors remplacer par "-".
Puis,
J'indexe la plage de données [Feuille A ; colonne A2:AU2500] et demande à rechercher l'équivalent de la valeur [Feuille B ; Cellule B3] dans la plage de données [Feuille A : colonne AH2:AH2500] pour m'affiche en cellule E3 la valeur correspondante de la colonne n°30 (cad : [Feuille A colonne 30].
Là aussi je suis preneur si vous avez des solutions pour améliorer...
Suite...
La suite du code permet de gérer un peu toute la mise en forme pour m'assurer qu'elle ne bouge jamais.
'Précise la police, la taille de police, l'alignement dans chaque cellule
With Range(Cells(3, 3), Cells(g, 10)).Font
.Name = "Calibri"
.Size = 9
.Bold = False
.Italic = False
End With
With Range(Cells(2, 1), Cells(2, 10)).Font
With Range(Cells(2, 2), Cells(g, 2)).Font
.Name = "Calibri"
.Size = 9
.Bold = True
.Italic = False
End With
End With
With Range(Cells(2, 1), Cells(g, 10)).Cells
.HorizontalAlignment = xlHAlignCenter 'soit : xlHAlignCenter soit : xlHAlignLeft soit : xlHAlignRight
.VerticalAlignment = xlVAlignCenter 'soit xlVAlignTop soit : xlVAlignCenter soit : xlVAlignBottom
End With
'Dimensionne le tableau pour qu'il s'intègre toujours au rapport
Columns("A").ColumnWidth = 20.9
Columns("B").ColumnWidth = 17.8
Columns("C").ColumnWidth = 22.7
Columns("D").ColumnWidth = 6.3
Columns("E").ColumnWidth = 10.9
Columns("F").ColumnWidth = 11.1
Columns("G").ColumnWidth = 6.9
Columns("H").ColumnWidth = 5.2
Columns("I").ColumnWidth = 17
Columns("J").ColumnWidth = 10.4
Rows(2).RowHeight = 26.7
For o = 3 To g
p = Cells(o, 1).Row
Range("A" & p).Rows.AutoFit
Next
'Renvoyer à la ligne automatiquement
With Range(Cells(2, 2), Cells(g, 10)).Cells
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Applique des bordures noires autours des cellules
Dim bordures As Range
For Each bordures In Range(Cells(2, 1), Cells(g, 10))
If bordures <> "" Then bordures.Borders.Weight = xlThin
If bordures = "" Then bordures.Borders.Weight = xlThin
Next
'Colore automatiquement les cellules
Dim a As Integer
For a = 3 To g
If Cells(a, 10) = "Très fort" Then
Range(Cells(a, 10), Cells(a, 10)).Interior.Color = RGB(192, 0, 0)
Range(Cells(a, 10), Cells(a, 10)).Font.Color = RGB(255, 255, 255)
Else
If Cells(a, 10) = "Fort" Then
Range(Cells(a, 10), Cells(a, 10)).Interior.Color = RGB(255, 0, 0)
Range(Cells(a, 10), Cells(a, 10)).Font.Color = RGB(0, 0, 0)
Else
If Cells(a, 10) = "Modéré" Then
Range(Cells(a, 10), Cells(a, 10)).Interior.Color = RGB(255, 192, 0)
Range(Cells(a, 10), Cells(a, 10)).Font.Color = RGB(0, 0, 0)
Else
If Cells(a, 10) = "Faible" Then
Range(Cells(a, 10), Cells(a, 10)).Interior.Color = RGB(255, 255, 153)
Range(Cells(a, 10), Cells(a, 10)).Font.Color = RGB(0, 0, 0)
Else
If Cells(a, 10) <> "Très fort" Then 'Or "Fort" Or "Modéré" Or "Faible"
Range(Cells(a, 10), Cells(a, 10)).Interior.Color = RGB(255, 255, 255)
Range(Cells(a, 10), Cells(a, 10)).Font.Color = RGB(0, 0, 0)
End If
End If
End If
End If
End If
Next
'Ne conserver que les valeurs
' Range(Cells(3, 4), Cells(g, 10)).Value = Range(Cells(3, 4), Cells(g, 10)).Value
'Classement des données dans l'ordre des enjeux + ordre des surfaces du + vers le -
Application.AddCustomList ListArray:=Array("Très fort", "Fort", "Modéré", "Faible", "Très faible", "Nul", " - ")
CustomOrder1 = Application.CustomListCount
Range(Cells(2, 1), Cells(g, 10)).Sort _
Key1:=Range(Cells(3, 10), Cells(g, 10)), OrderCustom:=CustomOrder1, _
Key2:=Range(Cells(3, 4), Cells(g, 4)), Order2:=xlDescending, _
Header:=xlYes, Orientation:=xlTopToBottomEnsuite, je commence à remplir la Feuille C
'Remplissage feuille impacts
With ws
'dernière ligne non vide de la colonne AH (34)
n3 = .Cells(.Rows.Count, 34).End(xlUp).Row 'AH
'plage à copier sans l'en-tête de colonne
Set rng2 = .Cells(2, 34).Resize(n3 - 1)
End With
With ws3
'dernière ligne non vide de la colonne A (1)
n4 = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
'cellule de destination de la copie de rng
Set Cell2 = .Cells(n4, 1)
End With
rng2.Copy Destination:=Cell2
With ws3
'dernière ligne non vide de la colonne A (1)
n4b = .Cells(.Rows.Count, 1).End(xlUp).Row 'B
'plage de cellules avec en-tête pour supprimer les doublons
Set rng2 = .Cells(1, 1).Resize(n4b - 1)
End With
n5 = ws3.Cells(Rows.Count, 1).End(xlUp).Row
For h = 4 To n5
ws3.Cells(h, 16).FormulaR1C1 = _
"=IF(INDEX(A!R[-2]C1:R2500C47,MATCH(RC[-15],A!R[-2]C34:R2500C34,0),46)=0,""-"",INDEX(A!R[-2]C1:R2500C47,MATCH(RC[-15],A!R[-2]C34:R2500C34,0),46))"
NextLa première partie du code est une autre méthode qui m'a été proposée sur ce forum et que je pourrai éventuellement reproduire pour remplacer une partie des formules ?
Ici, la formule fonctionne de la même façon que les précédentes.
Il y a également différents modules
modifvaleurs2
remdupli
sumdel
clecont
classauto
majhabs
modifvaleurs3
suppression2
styleQui permettent de réaliser des opérations d'une feuille à l'autre.
Je vais parler de ceux qui me posent problème.
Tout d'abord j'utilise ce code :
Rappel : n5 = ws3.Cells(Rows.Count, 1).End(xlUp).Row
For hb = 4 To n5
ws3.Cells(hb, 5).FormulaR1C1 = _
"=IF(SUMIF(A!R2C34:R2500C34,'C'!RC[-4],A!R2C45:R2500C45)=0,"" - "",SUMIF(A!R2C34:R2500C34,'C'!RC[-4],A!R2C45:R2500C45))"
ws3.Cells(hb, 6).FormulaR1C1 = _
"=IF(RC[10]=""Impact"",INDEX(A!R[-2]C1:R2500C47,MATCH(RC[-5],A!R[-2]C34:R2500C34,0),45),"" 0 "")"
ws3.Cells(hb, 2).FormulaR1C1 = _ "=IF(INDEX(A!R2C1:R2500C47,MATCH(RC[-1],A!R2C34:R2500C34,0),37)=0,""-"",INDEX(A!R2C1:R2500C47,MATCH(RC[-1],A!R2C34:R2500C34,0),37))"
NextPour les colonnes 5 [E] et 6 [F], de la Feuille C, j'applique des formules qui me permettent :
Colonne E : Calculer les somme des surfaces (Feuille A col AS) de chaque valeur inscrite en colonne A (feuille C)
> Ex. formule : =SI(SOMME.SI(A!$AH$2:$AH$2500;'C'!A4;A!$AS$2:$AS$2500)=0;" - ";SOMME.SI(A!$AH$2:$AH$2500;'C'!A4;A!$AS$2:$AS$2500))
Colonne F : Caculculer la somme des surfaces pour chaque valeur inscrite en colonne A impactée (l'impact est indiqué en feuille A, colonne AT) => Utiliser uniquement les surfaces pour lesquelles il est précisé "impact" en [Feuille A colonne AT]
> Ex. formule : =SI(P4="Impact";INDEX(A!$A2:$AU$2500;EQUIV(A4;A!$AH2:$AH$2500;0);45);" 0 ")
Là j'ai mon premier problème : Désormais, les impacts sont numéroté car il peut y en avoir plusieurs
impact 1 ; impact 2 ; impact 3 ; etc.
Cette formule ne permet donc plus de calculer les surfaces [Feuil A ; col 'AS'] touchées par chaque impact [Feuil A ; col 'AT'].
Auriez-vous une solution pour que : pour chacune des valeurs indiquées en Feuille A colonne 34 [AH], Excel calcule les surfaces [Feuil A ; col 'AS'] touchées par chaque impact [Feuil A ; col 'AT'] ?
suite...
En feuille C, pour chaque valeur en colonne A, un nombre de ligne est créé, équivalent au nombre d'impact présent en [Feuille A ; col AT].
Dans l'exemple, il y a 4 impacts, donc 4 lignes créées.
Pour ces 4 nouvelles lignes, j'aimerais que dans la [Feuille C colonne F] apparaissent les numéros des impacts (à savoir 1 (ligne 1), 2 (ligne 2), 3 (ligne 3) et 4 (ligne 4). Suivi (dans la même cellule), entre parenthèses, de la surface impactée (calculée précédemment*) et de la mention "ha".
1 (xx ha)
2 (xx ha)
3 (xx ha)
4 (xx ha)
*le calcul se faisant ainsi : Pour chaque valeur en [Feuille C ; colonne A] calculer les surfaces impactées [Feuille A ; col AS] pour impact 1, impact 2, impact 3, impact 4 [Feuille A ; col AT].
Un point compliqué est que ce nombre d'impact peut varier (min. 1, max. 9 ou +)
J'ai mis à jour mon document Excel, que je joins à ce post.
J'ai empêché l'exécution de certains modules, qu'on peut réactiver dans le code pour voir ce qu'ils font (beaucoup n'entrent pas en compte dans la résolution du problème).
nb_doublons
impactsPermettent de compter le nombre de doublons et de créer, ainsi, le nombre de lignes adéquat.
Dès que je peux, je vais essayer d'épurer, encore davantage, le code, pour ne conserver que ce qui est utile dans la résolution du problème.
Je vous remercie de votre attention !
J'ai peut-être un peu trop détaillé... J'essaye de décrire le plus précisément possible mon problème et espère qu'une solution existe.
Bonne soirée !
Sujet résolu, arrêt de l'utilisation de formules dans du code VBA.
Résolu en utilisant des macros.