Copier Coller avec insertion ligne, masque des lignes vides

Le 30/08/2017 à 22:32

Toujours 0

Le 30/08/2017 à 23:04

il me donne résultat 0 pour arrivée d'autre structure

Le 30/08/2017 à 23:26

il faudrait alors me redonner une version de code de la procédure "promoavenir(ligne)" qui fonctionnait et j'y apporterai à nouveau les modifs nécessaires.

Le 30/08/2017 à 23:43

code en bas

Public Sub SuiviPromos()

   Dim SetNames As Scripting.Dictionary
   Dim Names As Scripting.Dictionary
   Set SetNames = ListTabs 'la liste des mois Rhubics
   Set Names = ListTabs 'la liste des mois Rhubics ensuite completée par les prévisions

      Dim Ligne As Integer, LigneSave As Integer

    Ligne = 2
    'index de ligne courante
    'plus facile pour gérer les sauts de ligne ou les ajouts oubliés dans une catégorie

    'création de la feuille "Output"
    Sheets.Add
    ActiveSheet.Name = "Output"
    Call FillWhite

    Cells(1, 1).Value = " " 'sert à éviter de mettre la date et l'heure de la dernière mise à jour lors de RenameOutput

    Call BigTitle("suivi des promotions réalisées et à venir ", Ligne, 1)
    Ligne = Ligne + 3

     Ligne = Ligne
        Call BigTitle("Promo déjà réalisées (Rhubics) ", Ligne, 1)
        Ligne = Ligne

  Dim cell_copie As Range, nb_lignes As Integer, nb_colonnes As Integer, i As Integer
    Dim année As String
    Dim Total_années As New Scripting.Dictionary
    Total_années("Année") = "Total"    'initialisation de la collection correspondant au tableau Années

    Set cell_copie = Sheets("Output").Cells(Ligne + 2, "A")
    With Sheets("Mouvements")
        With .ListObjects("Tableau22")
            .Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
            .Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
            .Range.SpecialCells(xlCellTypeVisible).Copy cell_copie
            For i = 1 To .Range.Columns.Count
                .Range.AutoFilter Field:=i  'annulation filtres
            Next i
        End With
    End With
    With Sheets("Output")
        On Error Resume Next
        nb_lignes = .UsedRange.SpecialCells(xlCellTypeLastCell).Row - cell_copie.Row + 1
        nb_colonnes = .UsedRange.SpecialCells(xlCellTypeLastCell).Column - cell_copie.Column + 1
        .ListObjects.Add(xlSrcRange, cell_copie.Resize(nb_lignes, nb_colonnes), , xlYes).Name = "Tableau22"
        On Error GoTo 0
        With .ListObjects(1)
            '// remplissage tableau années
            For i = 1 To .ListRows.Count
                année = Right(.ListColumns(1).DataBodyRange.Rows(i), 4)
                Total_années(année) = Total_années(année) + 1
            Next i
            '// ajout ligne vierge et positionnement variable Ligne
          '  .ListRows.Add        'ajout 1igne vierge dans le tableau
            Ligne = .HeaderRowRange.Row + .ListRows.Count + 3   '2ème ligne libre après tableau
        ' ajuster les lignes
        Range(Cells(2, 20), Cells(i - 1, 20)).RowHeight = 33

        End With
        '// affichage tableau années
        nb_colonnes = Total_années.Count
        '//Application.Transpose :Renvoie une plage de cellules verticales sous forme de plage horizontale
        .Cells(Ligne, 1).Resize(, nb_colonnes).Value = Application.Transpose(Application.Transpose(Total_années.Keys))
        Ligne = Ligne + 1
        .Cells(Ligne, 1).Resize(, nb_colonnes).Value = Application.Transpose(Application.Transpose(Total_années.Items))
        Ligne = Ligne + 1
        'Pour mise en forme de tableau année
         Call TableVert(Cells(Ligne - 1, 1), Cells(Ligne - 1, Total_années.Count), 190, 190, 120)
         Call TableVert(Cells(Ligne - 2, 1), Cells(Ligne - 1, Total_années.Count), 190, 190, 120)

     ' mise en forme de tableau....................................

     ' ajuster les colonnes
    Columns("A").ColumnWidth = 16
    Columns("B").ColumnWidth = 5
    Columns("C").ColumnWidth = 6
    Columns("E").ColumnWidth = 8
    Columns("F").ColumnWidth = 14
    Columns("K").ColumnWidth = 9
    Columns("L").ColumnWidth = 9
    Columns("M").ColumnWidth = 7
    Columns("N").ColumnWidth = 8
    Columns("O").ColumnWidth = 10
    Columns("P").ColumnWidth = 4
    Columns("Q").ColumnWidth = 15
    Columns("R:R").ColumnWidth = 26 ' Pierre pour améliorer la présentation
    Columns("T").ColumnWidth = 13
    Rows(2).VerticalAlignment = xlTop

         ' Le commentaire

         Ligne = Ligne + 1
    Cells(Ligne, 1).Font.color = RGB(128, 0, 32) ' pour changer couleur de texte
    Cells(Ligne, 1).Font.Bold = True ' pour mettre le texte en gras
    Cells(Ligne, 1).Font.Size = 13 ' size de texte
    Cells(Ligne, 1).Value = "Attention les promotions venant d'une autre structure Rte ne peuvent pas être détectées ici, il faut les rajouter à la main "

    End With

    Call promoavenir(Ligne)
    Call TableauEmbauches(ThisWorkbook.Path & "\Previsions.xlsb", Ligne, 2, "", Names, "Mutation interne à la structure avec promo", ")()(", True)
    Call TableauEmbauches(ThisWorkbook.Path & "\Previsions.xlsb", Ligne, 2, "", Names, "Arrivée d'autres structures RTE avec promo", ")()(", True)
   Ligne = Ligne + 2
  ' Call TableauEmbauches(ThisWorkbook.Path & "\Previsions.xlsb", Ligne, 2, "Autres mouvements (Rhubics et Previsions)", Names, "", "Mutation", True)

    Call RenameOutput("SuiviPromos")
End Sub

Public Sub promoavenir(Ligne)
    'TODO
    'parcourir les mois en notant surtout l'année
    'lorsqu'on change d'année, traiter le groupe qu'on vient de passer

    Dim FSM As New FileSystemObject
    Dim MutY As New Scripting.Dictionary
    Dim MutM As New Scripting.Dictionary
    Dim TypesMut As New Collection

    TypesMut.Add "Mutation interne à la structure avec promo"
    TypesMut.Add "Arrivée d'autres structures RTE avec promo"
    PrevName = ThisWorkbook.Path & "\Previsions.xlsb"

    If SpFileExists(PrevName) Then
        Dim PrevBook As Excel.Workbook
        Application.DisplayAlerts = False
        Set PrevBook = Application.Workbooks.Open(PrevName, , , , , , , , , , , , , , xlRepairFile)
        For Each s In PrevBook.Sheets
            If s.visible = True Then
                With s
                    m = 6
                    Do While .Cells(m, 1).Value <> ""
                        Dim Merge As Range
                        Set Merge = .Cells(m, 1).MergeArea
                        date2 = .Cells(m, 1).Value
                        date1 = Mid(date2, Application.Max(1, InStrRev(date2, " ") + 1))
                        Set Rng = .Range(.Cells(Merge.Rows(1).Row, 1), .Cells(Merge.Rows(Merge.Rows.Count).Row, .Columns.Count))
                        For Each item In TypesMut
                            Call DoubleDicIncrement(MutY, date1, item, Application.WorksheetFunction.CountIf(Rng, item))
                            Call DoubleDicIncrement(MutM, date2, item, Application.WorksheetFunction.CountIf(Rng, item))
                        Next
                        m = m + Merge.Rows.Count
                    Loop
                End With
            End If
        Next
        PrevBook.Close
        Application.DisplayAlerts = True

       Ligne = Ligne + 3
        Call BigTitle("Promos à Venir (Prévisions)", Ligne, 1)
        Ligne = Ligne + 3
'Calcul total par ligne et par Année
       j = 1
        For Each item In TypesMut
            With Range(Cells(Ligne + j, 1), Cells(Ligne + j, 2))
                .Merge
                .Value = item
            End With
            i = 3
            For Each key In MutY.Keys
                With Cells(Ligne + 0, i)
                    .NumberFormat = "@"
                    .Value = ReduceMonth(key & " " & Chr(160))

               End With
                Cells(Ligne + j, i).Value = MutY(key)(item)
                i = i + 1
            Next
            Cells(Ligne + j, i).Value = "=SUM(" & Cells(Ligne + j, 3).Address & ":" & Cells(Ligne + j, i - 1).Address & ")"
            j = j + 1
        Next

        'total colonnes ...........................................................................................................

         Cells(Ligne + j, 1) = "TOTAL"
          Call TableVert(Cells(Ligne + j, 3), Cells(Ligne + j, i), 200, 250, 255)

          '..............................
         ' Application D 'une formule de somme pour la ligne = Ligne +j et les colonnes 3 à i.Pour que le formule soit transposée pour chaque colonne,
          'il est nécessaire que dans la formule les adresses soient relatives (ex: A1) et non absolues (ex: $A$1).
          'D'où la correction du .Address en .Address(0,0).
          '..............
        Range(Cells(Ligne + j, 3), Cells(Ligne + j, i)).Formula = "=SUM(" & Cells(Ligne + 1, 3).Address(0, 0) & ":" & Cells(Ligne + j - 1, 3).Address(0, 0) & ")"
        '.............
        '........................................................................................................................................

        Call TableVert(Cells(Ligne + 1, 1), Cells(Ligne + TypesMut.Count, MutY.Count + 2))
        Call TableVert(Cells(Ligne + 1, MutY.Count + 3), Cells(Ligne + TypesMut.Count, MutY.Count + 3), 200, 250, 255)
        Cells(Ligne, MutY.Count + 3).Value = "Total"
     'graphe avec total ....
       ' Ligne = Graphe(Ligne + TypesMut.Count + 1, Range(Cells(Ligne, 1), Cells(Ligne + TypesMut.Count + 1, MutY.Count + 2)), Range(Cells(Ligne + TypesMut.Count + 2, 3), Cells(Ligne + TypesMut.Count + 2, MutY.Count + 3)), xlColumnStacked, "recrutementsparannee")

'graphe sans total ....
 Ligne = Graphe(Ligne + TypesMut.Count, Range(Cells(Ligne, 1), Cells(Ligne + TypesMut.Count, MutY.Count + 2)), Range(Cells(Ligne + TypesMut.Count + 1, 3), Cells(Ligne + TypesMut.Count + 1, MutY.Count + 3)), xlColumnStacked, "recrutementsparannee")

    ActiveSheet.ChartObjects("recrutementsparannee").Activate
    ActiveChart.PlotArea.Select
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes("recrutementsparannee").ScaleHeight 0.9548611111, msoFalse, _
        msoScaleFromTopLeft
    ActiveChart.FullSeriesCollection(1).Select
    ActiveChart.PlotArea.Select
    Selection.Left = 20.915
    Selection.Top = 26.605
    Selection.Left = 20.915
    Selection.Top = 26.605
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes("recrutementsparannee").ScaleHeight 0.8945454545, msoFalse, _
        msoScaleFromBottomRight

        'copier-coller à factoriser ici

        j = 1
        For Each item In TypesMut
            With Range(Cells(Ligne + j, 1), Cells(Ligne + j, 2))
                .Merge
                .Value = item
            End With
            i = 3
            For Each key In MutM.Keys
                With Cells(Ligne + 0, i)
                    .NumberFormat = "@"
                    .Value = ReduceMonth(key & " " & Chr(160))
                    'un .NumberFormat="@" seul afficherait un warning sur la cellule, un espace serait automatiquement supprimé, un Chr(160) seul ferait planter ReduceMonth
                End With
                Cells(Ligne + j, i).Value = MutM(key)(item)
                i = i + 1
            Next
            Cells(Ligne + j, i).Value = "=SUM(" & Cells(Ligne + j, 3).Address & ":" & Cells(Ligne + j, i - 1).Address & ")"
            j = j + 1
        Next

        'total colonnes horizontal et vertical .............................................................................
        '.............................................
         Cells(Ligne + j, 1) = "TOTAL"
          Call TableVert(Cells(Ligne + j, 3), Cells(Ligne + j, i), 200, 250, 255)
        Range(Cells(Ligne + j, 3), Cells(Ligne + j, i)).Formula = "=SUM(" & Cells(Ligne + 1, 3).Address(0, 0) & ":" & Cells(Ligne + j - 1, 3).Address(0, 0) & ")"
        '........
        Call TableVert(Cells(Ligne + 1, 1), Cells(Ligne + TypesMut.Count, MutM.Count + 2))
        Call TableVert(Cells(Ligne + 1, MutM.Count + 3), Cells(Ligne + TypesMut.Count, MutM.Count + 3), 200, 250, 255)
        Cells(Ligne, MutM.Count + 3).Value = "Total"
        'graphe avect otal ....
       ' Ligne = Graphe(Ligne + TypesMut.Count + 1, Range(Cells(Ligne, 1), Cells(Ligne + TypesMut.Count + 1, MutM.Count + 2)), Range(Cells(Ligne + TypesMut.Count + 2, 3), Cells(Ligne + TypesMut.Count + 2, MutM.Count + 3)), xlColumnStacked, "recrutementsparmois")
        'graphe sans total ....
         Ligne = Graphe(Ligne + TypesMut.Count, Range(Cells(Ligne, 1), Cells(Ligne + TypesMut.Count, MutM.Count + 2)), Range(Cells(Ligne + TypesMut.Count + 1, 3), Cells(Ligne + TypesMut.Count + 1, MutM.Count + 3)), xlColumnStacked, "recrutementsparmois")

    ActiveChart.PlotArea.Select
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes("recrutementsparmois").IncrementLeft 3.75
    ActiveSheet.Shapes("recrutementsparmois").IncrementTop 39.75

       Else
        MsgBox "file does not exist"
    End If
    Set TypesEmb = Nothing
End Sub
Le 31/08/2017 à 10:24

En appliquant ces 2 premières modifications, est-ce que cela fonctionne toujours pour arrivée d'autre structure ?

1- variable à définir au niveau du module

Dim Récap_années As New Scripting.Dictionary

Public Sub SuiviPromos()

2- 2ème modification à effectuer

    °°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
    Dim cell_copie As Range, nb_lignes As Integer, nb_colonnes As Integer, i As Integer
    Dim année As Integer, tb()
    '// initialisation de la collection correspondant au tableau récapitulatif
    Set Récap_années = Nothing
    Récap_années("Récapitulatif") = Array("Promos réalisées", "Promos à venir", "Total")

    '// initialisation de la collection correspondant au tableau Années
    Dim Total_années As New Scripting.Dictionary
    Total_années("Année") = "Total"

    '// copie tableau22 avec filtrage sur la feuille Output
    Set cell_copie = Sheets("Output").Cells(ligne + 2, "A")
    With Sheets("Mouvements")
        With .ListObjects("Tableau22")
            .Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
            .Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
            .Range.SpecialCells(xlCellTypeVisible).Copy cell_copie
            For i = 1 To .Range.Columns.Count
                .Range.AutoFilter Field:=i 'annulation filtres
            Next i
        End With
    End With

    '// création tableau sur la feuille Output
    With Sheets("Output")
        On Error Resume Next
        nb_lignes = .UsedRange.SpecialCells(xlCellTypeLastCell).Row - cell_copie.Row + 1
        nb_colonnes = .UsedRange.SpecialCells(xlCellTypeLastCell).Column - cell_copie.Column + 1
        .ListObjects.Add(xlSrcRange, cell_copie.Resize(nb_lignes, nb_colonnes), , xlYes).Name = "Tableau22"
        On Error GoTo 0
        With .ListObjects(1)
            ' remplissage tableau années
            For i = 1 To .ListRows.Count
                année = Val(Right(.ListColumns(1).DataBodyRange.Rows(i), 4))
                Total_années(année) = Total_années(année) + 1
                If Not Récap_années.Exists(année) Then Récap_années(année) = Array("", "", "")
                tb = Récap_années(année): tb(0) = Val(tb(0)) + 1: tb(2) = Val(tb(2)) + 1: Récap_années(année) = tb
            Next i
            ligne = .HeaderRowRange.Row + .ListRows.Count + 3 '2ème ligne libre après tableau
         End With
        ' ajuster les lignes
         .Range(.Cells(2, 20), .Cells(i - 1, 20)).RowHeight = 33

        '// affichage tableau années
        nb_colonnes = Total_années.Count
        .Cells(ligne, 1).Resize(, nb_colonnes).Value = Total_années.Keys
        ligne = ligne + 1
        .Cells(ligne, 1).Resize(, nb_colonnes).Value = Total_années.Items
        ligne = ligne + 1
        'Pour mise en forme de tableau année
        Call TableVert(.Cells(ligne - 1, 1), .Cells(ligne - 1, Total_années.Count), 190, 190, 120)
        Call TableVert(.Cells(ligne - 2, 1), .Cells(ligne - 1, Total_années.Count), 190, 190, 120)
    End With
        °°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
Le 31/08/2017 à 14:54

toujours 0 ne marche pas

Le 31/08/2017 à 16:38

et le code que tu as fourni fonctionne sans les 2 modifications ci-dessus ?

Le 31/08/2017 à 22:04

Oui sans modification , il fonctionne très bien c'est déja vous que m'avais aider

Public Sub SuiviPromos()

   Dim SetNames As Scripting.Dictionary
   Dim Names As Scripting.Dictionary
   Set SetNames = ListTabs 'la liste des mois Rhubics
   Set Names = ListTabs 'la liste des mois Rhubics ensuite completée par les prévisions

      Dim Ligne As Integer, LigneSave As Integer

    Ligne = 2
    'index de ligne courante
    'plus facile pour gérer les sauts de ligne ou les ajouts oubliés dans une catégorie

    'création de la feuille "Output"
    Sheets.Add
    ActiveSheet.Name = "Output"
    Call FillWhite

    Cells(1, 1).Value = " " 'sert à éviter de mettre la date et l'heure de la dernière mise à jour lors de RenameOutput

    Call BigTitle("suivi des promotions réalisées et à venir ", Ligne, 1)
    Ligne = Ligne + 3

     Ligne = Ligne
        Call BigTitle("Promo déjà réalisées (Rhubics) ", Ligne, 1)
        Ligne = Ligne

  Dim cell_copie As Range, nb_lignes As Integer, nb_colonnes As Integer, i As Integer
    Dim année As String
    Dim Total_années As New Scripting.Dictionary
    Total_années("Année") = "Total"    'initialisation de la collection correspondant au tableau Années

    Set cell_copie = Sheets("Output").Cells(Ligne + 2, "A")
    With Sheets("Mouvements")
        With .ListObjects("Tableau22")
            .Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
            .Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
            .Range.SpecialCells(xlCellTypeVisible).Copy cell_copie
            For i = 1 To .Range.Columns.Count
                .Range.AutoFilter Field:=i  'annulation filtres
            Next i
        End With
    End With
    With Sheets("Output")
        On Error Resume Next
        nb_lignes = .UsedRange.SpecialCells(xlCellTypeLastCell).Row - cell_copie.Row + 1
        nb_colonnes = .UsedRange.SpecialCells(xlCellTypeLastCell).Column - cell_copie.Column + 1
        .ListObjects.Add(xlSrcRange, cell_copie.Resize(nb_lignes, nb_colonnes), , xlYes).Name = "Tableau22"
        On Error GoTo 0
        With .ListObjects(1)
            '// remplissage tableau années
            For i = 1 To .ListRows.Count
                année = Right(.ListColumns(1).DataBodyRange.Rows(i), 4)
                Total_années(année) = Total_années(année) + 1
            Next i
            '// ajout ligne vierge et positionnement variable Ligne
          '  .ListRows.Add        'ajout 1igne vierge dans le tableau
            Ligne = .HeaderRowRange.Row + .ListRows.Count + 3   '2ème ligne libre après tableau
        ' ajuster les lignes
        Range(Cells(2, 20), Cells(i - 1, 20)).RowHeight = 33

        End With
        '// affichage tableau années
        nb_colonnes = Total_années.Count
        '//Application.Transpose :Renvoie une plage de cellules verticales sous forme de plage horizontale
        .Cells(Ligne, 1).Resize(, nb_colonnes).Value = Application.Transpose(Application.Transpose(Total_années.Keys))
        Ligne = Ligne + 1
        .Cells(Ligne, 1).Resize(, nb_colonnes).Value = Application.Transpose(Application.Transpose(Total_années.Items))
        Ligne = Ligne + 1
        'Pour mise en forme de tableau année
         Call TableVert(Cells(Ligne - 1, 1), Cells(Ligne - 1, Total_années.Count), 190, 190, 120)
         Call TableVert(Cells(Ligne - 2, 1), Cells(Ligne - 1, Total_années.Count), 190, 190, 120)

     ' mise en forme de tableau....................................

     ' ajuster les colonnes
    Columns("A").ColumnWidth = 16
    Columns("B").ColumnWidth = 5
    Columns("C").ColumnWidth = 6
    Columns("E").ColumnWidth = 8
    Columns("F").ColumnWidth = 14
    Columns("K").ColumnWidth = 9
    Columns("L").ColumnWidth = 9
    Columns("M").ColumnWidth = 7
    Columns("N").ColumnWidth = 8
    Columns("O").ColumnWidth = 10
    Columns("P").ColumnWidth = 4
    Columns("Q").ColumnWidth = 15
    Columns("R:R").ColumnWidth = 26 ' Pierre pour améliorer la présentation
    Columns("T").ColumnWidth = 13
    Rows(2).VerticalAlignment = xlTop

         ' Le commentaire

         Ligne = Ligne + 1
    Cells(Ligne, 1).Font.color = RGB(128, 0, 32) ' pour changer couleur de texte
    Cells(Ligne, 1).Font.Bold = True ' pour mettre le texte en gras
    Cells(Ligne, 1).Font.Size = 13 ' size de texte
    Cells(Ligne, 1).Value = "Attention les promotions venant d'une autre structure Rte ne peuvent pas être détectées ici, il faut les rajouter à la main "

    End With

    Call promoavenir(Ligne)
    Call TableauEmbauches(ThisWorkbook.Path & "\Previsions.xlsb", Ligne, 2, "", Names, "Mutation interne à la structure avec promo", ")()(", True)
    Call TableauEmbauches(ThisWorkbook.Path & "\Previsions.xlsb", Ligne, 2, "", Names, "Arrivée d'autres structures RTE avec promo", ")()(", True)
   Ligne = Ligne + 2
  ' Call TableauEmbauches(ThisWorkbook.Path & "\Previsions.xlsb", Ligne, 2, "Autres mouvements (Rhubics et Previsions)", Names, "", "Mutation", True)

    Call RenameOutput("SuiviPromos")
End Sub

Public Sub promoavenir(Ligne)
    'TODO
    'parcourir les mois en notant surtout l'année
    'lorsqu'on change d'année, traiter le groupe qu'on vient de passer

    Dim FSM As New FileSystemObject
    Dim MutY As New Scripting.Dictionary
    Dim MutM As New Scripting.Dictionary
    Dim TypesMut As New Collection

    TypesMut.Add "Mutation interne à la structure avec promo"
    TypesMut.Add "Arrivée d'autres structures RTE avec promo"
    PrevName = ThisWorkbook.Path & "\Previsions.xlsb"

    If SpFileExists(PrevName) Then
        Dim PrevBook As Excel.Workbook
        Application.DisplayAlerts = False
        Set PrevBook = Application.Workbooks.Open(PrevName, , , , , , , , , , , , , , xlRepairFile)
        For Each s In PrevBook.Sheets
            If s.visible = True Then
                With s
                    m = 6
                    Do While .Cells(m, 1).Value <> ""
                        Dim Merge As Range
                        Set Merge = .Cells(m, 1).MergeArea
                        date2 = .Cells(m, 1).Value
                        date1 = Mid(date2, Application.Max(1, InStrRev(date2, " ") + 1))
                        Set Rng = .Range(.Cells(Merge.Rows(1).Row, 1), .Cells(Merge.Rows(Merge.Rows.Count).Row, .Columns.Count))
                        For Each item In TypesMut
                            Call DoubleDicIncrement(MutY, date1, item, Application.WorksheetFunction.CountIf(Rng, item))
                            Call DoubleDicIncrement(MutM, date2, item, Application.WorksheetFunction.CountIf(Rng, item))
                        Next
                        m = m + Merge.Rows.Count
                    Loop
                End With
            End If
        Next
        PrevBook.Close
        Application.DisplayAlerts = True

       Ligne = Ligne + 3
        Call BigTitle("Promos à Venir (Prévisions)", Ligne, 1)
        Ligne = Ligne + 3
'Calcul total par ligne et par Année
       j = 1
        For Each item In TypesMut
            With Range(Cells(Ligne + j, 1), Cells(Ligne + j, 2))
                .Merge
                .Value = item
            End With
            i = 3
            For Each key In MutY.Keys
                With Cells(Ligne + 0, i)
                    .NumberFormat = "@"
                    .Value = ReduceMonth(key & " " & Chr(160))

               End With
                Cells(Ligne + j, i).Value = MutY(key)(item)
                i = i + 1
            Next
            Cells(Ligne + j, i).Value = "=SUM(" & Cells(Ligne + j, 3).Address & ":" & Cells(Ligne + j, i - 1).Address & ")"
            j = j + 1
        Next

        'total colonnes ...........................................................................................................

         Cells(Ligne + j, 1) = "TOTAL"
          Call TableVert(Cells(Ligne + j, 3), Cells(Ligne + j, i), 200, 250, 255)

          '..............................
         ' Application D 'une formule de somme pour la ligne = Ligne +j et les colonnes 3 à i.Pour que le formule soit transposée pour chaque colonne,
          'il est nécessaire que dans la formule les adresses soient relatives (ex: A1) et non absolues (ex: $A$1).
          'D'où la correction du .Address en .Address(0,0).
          '..............
        Range(Cells(Ligne + j, 3), Cells(Ligne + j, i)).Formula = "=SUM(" & Cells(Ligne + 1, 3).Address(0, 0) & ":" & Cells(Ligne + j - 1, 3).Address(0, 0) & ")"
        '.............
        '........................................................................................................................................

        Call TableVert(Cells(Ligne + 1, 1), Cells(Ligne + TypesMut.Count, MutY.Count + 2))
        Call TableVert(Cells(Ligne + 1, MutY.Count + 3), Cells(Ligne + TypesMut.Count, MutY.Count + 3), 200, 250, 255)
        Cells(Ligne, MutY.Count + 3).Value = "Total"
     'graphe avec total ....
       ' Ligne = Graphe(Ligne + TypesMut.Count + 1, Range(Cells(Ligne, 1), Cells(Ligne + TypesMut.Count + 1, MutY.Count + 2)), Range(Cells(Ligne + TypesMut.Count + 2, 3), Cells(Ligne + TypesMut.Count + 2, MutY.Count + 3)), xlColumnStacked, "recrutementsparannee")

'graphe sans total ....
 Ligne = Graphe(Ligne + TypesMut.Count, Range(Cells(Ligne, 1), Cells(Ligne + TypesMut.Count, MutY.Count + 2)), Range(Cells(Ligne + TypesMut.Count + 1, 3), Cells(Ligne + TypesMut.Count + 1, MutY.Count + 3)), xlColumnStacked, "recrutementsparannee")

    ActiveSheet.ChartObjects("recrutementsparannee").Activate
    ActiveChart.PlotArea.Select
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes("recrutementsparannee").ScaleHeight 0.9548611111, msoFalse, _
        msoScaleFromTopLeft
    ActiveChart.FullSeriesCollection(1).Select
    ActiveChart.PlotArea.Select
    Selection.Left = 20.915
    Selection.Top = 26.605
    Selection.Left = 20.915
    Selection.Top = 26.605
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes("recrutementsparannee").ScaleHeight 0.8945454545, msoFalse, _
        msoScaleFromBottomRight

        'copier-coller à factoriser ici

        j = 1
        For Each item In TypesMut
            With Range(Cells(Ligne + j, 1), Cells(Ligne + j, 2))
                .Merge
                .Value = item
            End With
            i = 3
            For Each key In MutM.Keys
                With Cells(Ligne + 0, i)
                    .NumberFormat = "@"
                    .Value = ReduceMonth(key & " " & Chr(160))
                    'un .NumberFormat="@" seul afficherait un warning sur la cellule, un espace serait automatiquement supprimé, un Chr(160) seul ferait planter ReduceMonth
                End With
                Cells(Ligne + j, i).Value = MutM(key)(item)
                i = i + 1
            Next
            Cells(Ligne + j, i).Value = "=SUM(" & Cells(Ligne + j, 3).Address & ":" & Cells(Ligne + j, i - 1).Address & ")"
            j = j + 1
        Next

        'total colonnes horizontal et vertical .............................................................................
        '.............................................
         Cells(Ligne + j, 1) = "TOTAL"
          Call TableVert(Cells(Ligne + j, 3), Cells(Ligne + j, i), 200, 250, 255)
        Range(Cells(Ligne + j, 3), Cells(Ligne + j, i)).Formula = "=SUM(" & Cells(Ligne + 1, 3).Address(0, 0) & ":" & Cells(Ligne + j - 1, 3).Address(0, 0) & ")"
        '........
        Call TableVert(Cells(Ligne + 1, 1), Cells(Ligne + TypesMut.Count, MutM.Count + 2))
        Call TableVert(Cells(Ligne + 1, MutM.Count + 3), Cells(Ligne + TypesMut.Count, MutM.Count + 3), 200, 250, 255)
        Cells(Ligne, MutM.Count + 3).Value = "Total"
        'graphe avect otal ....
       ' Ligne = Graphe(Ligne + TypesMut.Count + 1, Range(Cells(Ligne, 1), Cells(Ligne + TypesMut.Count + 1, MutM.Count + 2)), Range(Cells(Ligne + TypesMut.Count + 2, 3), Cells(Ligne + TypesMut.Count + 2, MutM.Count + 3)), xlColumnStacked, "recrutementsparmois")
        'graphe sans total ....
         Ligne = Graphe(Ligne + TypesMut.Count, Range(Cells(Ligne, 1), Cells(Ligne + TypesMut.Count, MutM.Count + 2)), Range(Cells(Ligne + TypesMut.Count + 1, 3), Cells(Ligne + TypesMut.Count + 1, MutM.Count + 3)), xlColumnStacked, "recrutementsparmois")

    ActiveChart.PlotArea.Select
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes("recrutementsparmois").IncrementLeft 3.75
    ActiveSheet.Shapes("recrutementsparmois").IncrementTop 39.75

       Else
        MsgBox "file does not exist"
    End If
    Set TypesEmb = Nothing
End Sub
Le 31/08/2017 à 22:39

Essayer la première modification

1- variable à définir au niveau du module

Dim Récap_années As New Scripting.Dictionary

Cette variable doit être au début du module avant la première procédure de ce dernier qui n'est pas forcément "Sub SuiviPromos"

Est-ce que cela continue à fonctionner après cette première modification ?

Si ça fonctionne, il faudra essayer les modifications au fur et à mesure jusqu'à trouver ce qui coince .

Le 31/08/2017 à 22:42

oui je met que ça avec l'ancien code que fonctionne

Dim Récap_années As New Scripting.Dictionary
Le 31/08/2017 à 22:45

bon. essayer cette 2ème modif

    Dim cell_copie As Range, nb_lignes As Integer, nb_colonnes As Integer, i As Integer
    Dim année As Integer, tb()
    '// initialisation de la collection correspondant au tableau récapitulatif
   Set Récap_années = Nothing
    Récap_années("Récapitulatif") = Array("Promos réalisées", "Promos à venir", "Total")

si ça fonctionne, essayer cette 3ème modif

        With .ListObjects(1)
            ' remplissage tableau années
           For i = 1 To .ListRows.Count
                année = Val(Right(.ListColumns(1).DataBodyRange.Rows(i), 4))
                Total_années(année) = Total_années(année) + 1
                If Not Récap_années.Exists(année) Then Récap_années(année) = Array("", "", "")
                tb = Récap_années(année): tb(0) = Val(tb(0)) + 1: tb(2) = Val(tb(2)) + 1: Récap_années(année) = tb
            Next i
            ligne = .HeaderRowRange.Row + .ListRows.Count + 3 '2ème ligne libre après tableau
        End With
Le 31/08/2017 à 22:54

jusqu'à maintenant ca fonctionne

Je le mets ou exactement

   With .ListObjects(1)
            ' remplissage tableau années
           For i = 1 To .ListRows.Count
                année = Val(Right(.ListColumns(1).DataBodyRange.Rows(i), 4))
                Total_années(année) = Total_années(année) + 1
                If Not Récap_années.Exists(année) Then Récap_années(année) = Array("", "", "")
                tb = Récap_années(année): tb(0) = Val(tb(0)) + 1: tb(2) = Val(tb(2)) + 1: Récap_années(année) = tb
            Next i
            Ligne = .HeaderRowRange.Row + .ListRows.Count + 3 '2ème ligne libre après tableau
        End With
Dim cell_copie As Range, nb_lignes As Integer, nb_colonnes As Integer, i As Integer
    Dim année As Integer, tb()
    '// initialisation de la collection correspondant au tableau récapitulatif
   Set Récap_années = Nothing
    Récap_années("Récapitulatif") = Array("Promos réalisées", "Promos à venir", "Total")

    Dim Total_années As New Scripting.Dictionary
    Total_années("Année") = "Total"    'initialisation de la collection correspondant au tableau Années

    Set cell_copie = Sheets("Output").Cells(Ligne + 2, "A")
    With Sheets("Mouvements")

            With .ListObjects(1)
            ' remplissage tableau années
           For i = 1 To .ListRows.Count
                année = Val(Right(.ListColumns(1).DataBodyRange.Rows(i), 4))
                Total_années(année) = Total_années(année) + 1
                If Not Récap_années.Exists(année) Then Récap_années(année) = Array("", "", "")
                tb = Récap_années(année): tb(0) = Val(tb(0)) + 1: tb(2) = Val(tb(2)) + 1: Récap_années(année) = tb
            Next i
            Ligne = .HeaderRowRange.Row + .ListRows.Count + 3 '2ème ligne libre après tableau
        End With

        With .ListObjects("Tableau22")
            .Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
            .Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
            .Range.SpecialCells(xlCellTypeVisible).Copy cell_copie
            For i = 1 To .Range.Columns.Count
                .Range.AutoFilter Field:=i  'annulation filtres
            Next i
        End With
    End With
    With Sheets("Output")
        On Error Resume Next
        nb_lignes = .UsedRange.SpecialCells(xlCellTypeLastCell).Row - cell_copie.Row + 1
        nb_colonnes = .UsedRange.SpecialCells(xlCellTypeLastCell).Column - cell_copie.Column + 1
        .ListObjects.Add(xlSrcRange, cell_copie.Resize(nb_lignes, nb_colonnes), , xlYes).Name = "Tableau22"
        On Error GoTo 0
        With .ListObjects(1)
            '// remplissage tableau années
            For i = 1 To .ListRows.Count
                année = Right(.ListColumns(1).DataBodyRange.Rows(i), 4)
                Total_années(année) = Total_années(année) + 1
            Next i
            '// ajout ligne vierge et positionnement variable Ligne
          '  .ListRows.Add        'ajout 1igne vierge dans le tableau
            Ligne = .HeaderRowRange.Row + .ListRows.Count + 3   '2ème ligne libre après tableau
        ' ajuster les lignes
        Range(Cells(2, 20), Cells(i - 1, 20)).RowHeight = 33

        End With
Le 31/08/2017 à 23:16

il est mal placé. Il doit être placé après ces instructions

With Sheets("Output")
        On Error Resume Next
        nb_lignes = .UsedRange.SpecialCells(xlCellTypeLastCell).Row - cell_copie.Row + 1
        nb_colonnes = .UsedRange.SpecialCells(xlCellTypeLastCell).Column - cell_copie.Column + 1
        .ListObjects.Add(xlSrcRange, cell_copie.Resize(nb_lignes, nb_colonnes), , xlYes).Name = "Tableau22"
        On Error GoTo 0
Le 31/08/2017 à 23:24

il s'excute pas il dis référence incorrecte

  .Cells(Ligne, 1).Resize(, nb_colonnes).Value = Application.Transpose(Application.Transpose(Total_années.Keys))
Le 31/08/2017 à 23:34

On ne vas pas en sortir comme ça.

joignez-moi un classeur sans les données contenant le code complet qui fonctionne.

Le 31/08/2017 à 23:36

il y a deux , ou il récupère leur données aussi , je vais essayer

Le 01/09/2017 à 00:00
5p.xlsb (86.52 Ko)
Le 01/09/2017 à 09:10

Cette version fonctionne-t-elle ?

4p2.xlsb (86.68 Ko)
Le 01/09/2017 à 09:19

Oui

Mais il n'est pas afficher le tableau recp

Le 01/09/2017 à 09:58

C'est normal car je n'ai pas appliqué la modification de la procédure "promoavenir(Ligne)"

8p3.xlsb (87.67 Ko)
Rechercher des sujets similaires à "copier coller insertion ligne masque lignes vides"