XL 2010 FAIRE LISTE AUTOMATIQUE SUIVANT NOMBRES

[mcj1997]

Bonjour,

En PJ, problématique pour générer en automatique des listes suivant deux critères.

Merci d'avance,

 

[Dranreb]

Ça devient compliqué. On ne sait plus du tout s'il faut réviser toutes les lignes comme compris en dernier ou seulement ajouter de nouvelles lignes. Et que faire si vous décochez seulement un élément de la ligne 7 ?
Peut être que le maximum, s'il peut changer, devrait être saisi à partir des lignes commençant à la C12 et non plus à la C11 ?

 

[mcj1997]

Oubliez le dernier message et je referai plus claire.

 

[Dranreb]

Essayez ça :

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Total As Double, MaxPF As Double, NbLig As Long, RngLig As Range
   If Intersect(Target, [D7:AD7,C11,D12:AD1000], Target) Is Nothing Then Exit Sub
   Total = [C9].Value
   MaxPF = [C11].Value
   NbLig = Int(Total / MaxPF): If NbLig * MaxPF < Total Then NbLig = NbLig + 1
   If NbLig = 0 Then NbLig = 1
   Set RngLig = [B12:AD12].Resize(NbLig)
   Application.EnableEvents = False
   [D9:AD9].FormulaR1C1 = "=IF(ISBLANK(R7C),0,R6C)"
   With RngLig.Offset(NbLig).Resize(1000)
      .Borders(xlEdgeBottom).LineStyle = xlNone
      .Borders(xlInsideHorizontal).LineStyle = xlNone
      .ClearContents: End With
   With RngLig.Borders(xlEdgeBottom): .LineStyle = xlContinuous: .Weight = xlMedium: End With
   With RngLig.Borders(xlInsideHorizontal): .LineStyle = xlContinuous: .Weight = xlThin: End With
   RngLig.FormulaR1C1 = "=MIN(MAX(RC3-SUM(RC4:RC[-1]),0),MAX(R9C-SUM(R12C:R[-1]C),0))"
   RngLig.Columns(3).FormulaR1C1 = "=MIN(MAX(RC3,0),MAX(R9C-SUM(R12C:R[-1]C),0))"
   RngLig.Rows(1).FormulaR1C1 = "=MIN(MAX(RC3-SUM(RC4:RC[-1]),0),R9C)"
   RngLig(1, 3).FormulaR1C1 = "=MIN(MAX(RC3,0),R9C)"
   RngLig.Columns(2).Value = MaxPF
   If RngLig.Rows.Count > 1 Then
      RngLig.Rows(RngLig.Rows.Count).FormulaR1C1 = "=R9C-SUM(R12C:R[-1]C)"
   Else
      RngLig.Rows(1).FormulaR1C1 = "=R9C": End If
   RngLig.Columns(1).FormulaR1C1 = "=""PF ""&ROW()-" & RngLig.Row - 1
   RngLig.Value = RngLig.Value
   Application.EnableEvents = True
   ActiveWindow.DisplayZeros = False
   End Sub

 

[mcj1997]

Trop fort ! merci beaucoup, je poursuis la finalisation.

 

[mcj1997]

C'est top, je viens de tester à nouveau.
Je joins un fichier avec en feuil2 l'adaptation dont j'aurai besoin.

Merci d'avance,

 

[Dranreb]

Ça pourrait donner quelque chose comme ça :

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim NbPaq As Long, TLPaq() As Long, Cel As Range, N As Long, LFin As Long
   NbPaq = WorksheetFunction.CountIf(Columns("B"), "BUREAU")
   ReDim TLPaq(1 To NbPaq)
   Set Cel = Columns("B").Find(What:="BUREAU", LookIn:=xlValues, _
      LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
      MatchCase:=True, SearchFormat:=False)
   For N = 1 To UBound(TLPaq)
      TLPaq(N) = Cel.Row
      Set Cel = Columns("B").FindNext(After:=Cel)
      Next N
   With Me.UsedRange: LFin = .Rows(.Rows.Count).Row: End With
   For N = UBound(TLPaq) To 1 Step -1
      TraiterPaquet [B:AD].Rows(TLPaq(N) - 1).Resize(LFin - TLPaq(N) + 2).Cells, Target
      LFin = TLPaq(N) - 3: Next N
   ActiveWindow.DisplayZeros = False
   End Sub
Private Sub TraiterPaquet(ByVal RngPaq As Range, ByVal Cible As Range)
   Dim Total As Double, MaxPF As Double, NbLig As Long, DifLigs As Long, RngLig As Range, R9$, R12$
   If Intersect(RngPaq, Cible) Is Nothing Then Exit Sub
   Total = RngPaq(3, 2).Value
   MaxPF = RngPaq(5, 2).Value
   NbLig = Int(Total / MaxPF): If NbLig * MaxPF < Total Then NbLig = NbLig + 1
   If NbLig = 0 Then NbLig = 1
   DifLigs = RngPaq.Rows.Count - 5 - NbLig
   Application.EnableEvents = False
   If DifLigs < 0 Then
      RngPaq.Rows(RngPaq.Rows.Count).Resize(-DifLigs).Insert xlShiftDown, xlFormatFromLeftOrAbove
   ElseIf DifLigs > 0 Then
      RngPaq.Rows(6).Resize(DifLigs).Delete xlShiftUp
      End If
   Set RngLig = RngPaq.Rows(6).Resize(NbLig).Cells
   Application.ScreenUpdating = False
   With RngLig.Borders(xlEdgeBottom): .LineStyle = xlContinuous: .Weight = xlMedium: End With
   With RngLig.Borders(xlInsideHorizontal): .LineStyle = xlContinuous: .Weight = xlThin: End With
   Application.Calculation = xlCalculationManual
   R9 = "R" & RngPaq.Rows(3).Row
   R12 = "R" & RngPaq.Rows(6).Row
   RngLig.FormulaR1C1 = "=MIN(MAX(RC3-SUM(RC4:RC[-1]),0),MAX(" & R9 & "C-SUM(" & R12 & "C:R[-1]C),0))"
   RngLig.Columns(3).FormulaR1C1 = "=MIN(MAX(RC3,0),MAX(" & R9 & "C-SUM(" & R12 & "C:R[-1]C),0))"
   RngLig.Rows(1).FormulaR1C1 = "=MIN(MAX(RC3-SUM(RC4:RC[-1]),0)," & R9 & "C)"
   RngLig(1, 3).FormulaR1C1 = "=MIN(RC3," & R9 & "C)"
   RngLig.Columns(2).Value = MaxPF
   If RngLig.Rows.Count > 1 Then
      RngLig.Rows(RngLig.Rows.Count).FormulaR1C1 = "=" & R9 & "C-SUM(" & R12 & "C:R[-1]C)"
   Else
      RngLig.Rows(1).FormulaR1C1 = "=" & R9 & "C": End If
   RngLig.Columns(1).FormulaR1C1 = "=""PF ""&ROW()-" & RngLig.Row - 1
   Application.Calculation = xlCalculationAutomatic
'  RngLig.Value = RngLig.Value
   Application.EnableEvents = True
   End Sub

 

[mcj1997]

Bonjour,

Tout d'abord merci de poursuivre l'évolution de mon fichier, c'est vraiment top.
Toutefois, je n'arrive pas à basculer "total cat" en B8 fichier en PJ.

Merci encore

 

[Dranreb]

Bonjour.
Je ne comprends pas trop ce que vous voulez dire, mais je vois que vous avez changé le code de Feuil1 (Feuil1) où il n'y a qu'un seul paquet et qu'il n'y a aucun code dans Feuil2 (Feuil2)
Mais pour créer un nouveau paquet il faut impérativement copier tout le dernier paquet en dessous, en laissant une ligne, parce que s'il ne trouve pas un nouveau "BUREAU" en colonne B, il va considérer que tout fait encore partie du dernier paquet, et y est de trop, et le supprime donc. Il y a divers détails à régler dans le code par ailleurs.

 

[mcj1997]

Je ne pensais pas me servir de la feuil2, c'est pour cela qu'il n'y a aucun code.

 

[Dranreb]

Soit. Pour déterminer les paquets le code se base sur la présence du mot "BUREAU". J'espère que ce mot, bien isolé, était un bon critère. Sinon indiquez m'en un autre. Vous m'inquiétez avec votre B8: elle contient justement un "BUREAU" dans la "Feuil1".

 

[mcj1997]

En C8, je pensais que c'était vous qui aviez adapté un code, je n'ai pas de variable en C8.

Ce que j'aimerai arriver à faire est que tant que je n'ai pas réparti toutes les catégories (total ligne 6), un tableau en dessous le dernier portefeuille s'ouvre afin de reselectionner une nouvelle taille de portefeuille et ainsi de suite jusqu'à ce que mon total ligne 6 soit épuisé.

Je pense à une solution peut-être, partir du premier tableau en haut, laisser une dizaine de ligne afin que la macro affiche les lignes, faire un second tableau avec une nouvelle macro qui démarrerait avec celui ci, laisser une dizaine de ligne ....... et ainsi de suite.
Avoir la restitution comme l'exemple en feuil2.

 

[Dranreb]

Je ne fabrique pas de nouveaux paquets tout entiers, pour l'instant, c'est à vous de le faire.
Est-ce que, plutôt qu'une bande noire entre les paquets, on ne pourrait pas y mettre les chiffres restants justement ?
Seul le 1er paquet s'appuierait sur la ligne 6, les suivants s'appuieraient sur cette ligne là …

 

[mcj1997]

Je ne fabrique pas de nouveaux paquets tout entiers, pour l'instant, c'est à vous de le faire.
Est-ce que, plutôt qu'une bande noire entre les paquets, on ne pourrait pas y mettre les chiffres restants justement ?
Seul le 1er paquet s'appuierait sur la ligne 6, les suivants s'appuieraient sur cette ligne là …

Je vais faire une présentation en découpant la feuille en 8 (car 8 tailles possibles) et essayer d’adapter la macro en en faisant une par taille en adaptant les adresses bien sûr mais peut il y aura possibilité de simplifier en ne faisant qu’une macro avec plusieurs « adresses »

 

[mcj1997]

J'ai adapté la présentation afin d'avoir tout sur la feuil1, il me faudrait maintenant adapter la macro afin que cela fonctionne en sélectionnant les tailles en C11, C22, C35.

J'ai laissé à chaque fois 6 lignes car c'est le nombre maximum de portefeuille par taille.

Merci d'avance

 

[Dranreb]

Ah bon, les paquets ne changent plus de taille alors ? Moi qui m'étais décarcassé pour insérer les lignes supplémentaires nécessaires et supprimer celles en trop …
Vous savez quoi, j'ai l'impression qu'il n'y a peut être plus besoin de macro, et que tout pourrait se faire par formules.
Mais il serait utile à mon avis d'utiliser les lignes 19, 32, 45, 58, 71, 84 et 97, voire la 110 aussi pour vérifier qu'il ne reste rien, pour y mettre les restants non ventilés.
Ça pourrait simplifier aussi bien l'utilisation du classeur que les formules, parce celles ci ne s'appuieraient que sur ces restants, seul le 1er paquet se réfèrerait à la ligne 6. L'utilisation en serait simplifiée parce qu'on verrait tout de suite juste au dessus, comme pour le 1er paquet, s'il reste un montant cochable.