Copier Coller avec insertion ligne, masque des lignes vides

Le 10/08/2017 à 11:45

Débutant en VBA.

voila ma question:

J'ai un tableau que s'appel mouvements , il contient des nom des gens qui quitte l'entreprise , autre qui arrive et les autres qui vont des mutations , avec ou sans changement des salaires.

Je veux copier ce tableau (qui peut varier) après faire filtrage sur leurs salaire que eu un changement (en gros les gens de l'entreprise qui vont des mutation avec changements des salaires ) sur la feuil2 et la coller sur la feuil3 puis faire sommes des NR. en masquant les lignes vides .

Mon tableau est rassemble a l'image ci-dessous:

tmvt

ce que je veux l'obtenir :

tmvt2

Donc j'ai essayé avec ce code

 With Sheets("Mouvements")
    i = 3

        Do While .Cells(i, 2).Value <> ""    'La colonne 2 correspond au type de mouvement

            ' Calcul du nombre de promotions en scrutant chacune des lignes sur la colonne 14 (NR)
            If (InStr(.Cells(i, 14).Value, "->") <> 0) Then
            ' La chaine de caractère contient "->" donc c'est une promotion
        Sheets("Mouvements").Select
        Range(Cells(i, 1), Cells(i, 19)).Copy
        Sheets("Output").Select
        Range(Cells(i, 1), Cells(i, 19)).PasteSpecial Paste:=xlPasteValues

       Call TableVert(Cells(i, 1), Cells(i, 21))
            End If

            i = i + 1

        Loop

    End With

J'ai obtient cette résultat :

obtient

Donc j'ai besoin d'aide déjà j'arrive pas a copier coller l'en-tête de tableau puis de masquer les lignes vides , aussi après ce tableau j'ai autre titre et des autres tableaux donc j'aimerai bien que je peux garder la mise en forme lorsque je fais l'insertion de ce tableau.

J'espère que c'est clair

Merci d'avance pour vos réponses,

Le 10/08/2017 à 17:11

Bonjour,

Question préalable : ce tableau est-il un objet tableau Excel, autrement dit si tu cliques sur une des cellules du tableau apparaît-il en haut au milieu de la fenêtre "OUTILS DE TABLEAU" ?

Le 11/08/2017 à 08:43

Oui, par contre ce tableau, il est créer a partir d'un autre fichier Excel et la mise en forme est programmer

Le 11/08/2017 à 11:15

Bonjour,

En cliquant sur OUTILS DE TABLEAU, en haut à gauche est indiqué le nom de l'objet tableau. En supposant que ce nom soit "Tableau1",ci-dessous exemple de code avec recopie du tableau filtré sur la feuille Output en un nouvel objet tableau avec une ligne total.

    With Sheets("Mouvements")
        .ListObjects("Tableau1").Range.AutoFilter Field:=2, Criteria1:="->"  'Filtrage avec ->
         .ListObjects("Tableau1").Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A1")
    End With
    With Sheets("Output")
        .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "Tableau1"
        .ListObjects("Tableau1").ShowTotals = True      'affichage ligne Total
     End With

Pour comprendre l'intérêt et le fonctionnement d'un objet Tableau (Menu Insérer --> Tableau), voir

https://support.office.com/fr-fr/article/Cr%C3%A9ation-ou-suppression-d-un-tableau-Excel-e81aa349-b006-4f8a-9806-5af9df0ac664

Le 11/08/2017 à 11:34

désolé mais Je comprends pas votre idée

Je veux pas filtré sur ma feuille mouvement pour que je puisse génère la feuille output. Je veux bien que tout marche en // de façon il copie les données de tableau mvt avec le filtrage sur ma cellule 14 qui contient le petit flèche "->" mais le problème rencontre que avec ma boucle il parcours le tableau il copie les valeurs de chaque ligne ou la cellule 14 contient le petit flèche "->" en même temps il copie les autres lignes de façon vide mais j'aimerai bien qu'il copie bien que les ligne ou contient le petit flèche "->"et mettre en même formats et il écrase pas les autres données dans la feuille

Le 11/08/2017 à 12:11

Il suffit de filtrer la colonne Type du Tableau "Mouvements" avec la petite flèche "->" et d'appliquer mon code. Vous obtiendrez sur la feuille Output le résultat souhaité.

Le 11/08/2017 à 13:15

voila mon code complet :

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 i As Integer

    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

    Call BigTitle("Suivi Promotions", Ligne, 1)
    Ligne = Ligne + 3

 With Sheets("Mouvements")
    i = 3

    Do While .Cells(i, 2).Value <> ""    'La colonne 2 correspond au type de mouvement

            ' Calcul du nombre de promotions en scrutant chacune des lignes sur la colonne 14 (NR)
            If (InStr(.Cells(i, 14).Value, "->") <> 0) Then
            ' La chaine de caractère contient "->" donc c'est une promotion
                     Sheets("Mouvements").Select
                     Range(Cells(i, 1), Cells(i, 21)).Copy
                     Sheets("Output").Select
                     Range(Cells(i, 1), Cells(i, 21)).PasteSpecial Paste:=xlPasteValues
                     Rows(i - 1).RowHeight = 0
                     Call TableVert(Cells(i, 1), Cells(i, 21))
                     End If
                     ' Sheets("Output").Range(Cells(i - 1, 1), Cells(i - 1, 21)).Hidden = True

            i = i + 1

    Loop

    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

Après les autres procédures , j'arrive pas a comprendre ou j'applique votre code par rapport a mon code , en plus de ca pour la feuille mvt j'ai virement un long code

Le 11/08/2017 à 14:06

Je remplacerais les instructions

With Sheets("Mouvements")

à

End with

par mon code.

Ne pas oublier de remplacer si nécessaire "Tableau1" par le nom de votre Tableau que vous obtiendrez en cliquant sur OUTILS DE TABLEAU, en haut à gauche,

Le 11/08/2017 à 14:35
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 i As Integer

    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

    Call BigTitle("Suivi Promotions", Ligne, 1)
    Ligne = Ligne + 3

    With Sheets("Mouvements")
        .ListObjects("Tableau22").Range.AutoFilter Field:=2, Criteria1:="->"  'Filtrage avec ->
         .ListObjects("Tableau22").Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A7")
    End With
    With Sheets("Output")
        .ListObjects.Add(xlSrcRange, .Range("A7").CurrentRegion, , xlYes).Name = "Tableau22"
        .ListObjects("Tableau22").ShowTotals = True      'affichage ligne Total
     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

J'ai comme résultat ça :

reslt
Le 11/08/2017 à 15:35

si je regarde votre tableau à afficher, il semble que le critère de filtrage soit "/" et non "->".

    With Sheets("Mouvements")
        .ListObjects("Tableau22").Range.AutoFilter Field:=2, Criteria1:="/"  'Filtrage avec /

A priori, le souci vient du caractère de filtrage de la colonne 2 du tableau. Vérifiez donc ce caractère.

Le 12/08/2017 à 00:01

En fait je doit vérifier que la colonne 2 qui n'est pas vide puis je mets condition sur la colonne qui doit contenir -> qui il est de type '/' , alors qu'on peut trouvé aussi sur la colonne NR des valeurs sans fléche mais de type aussi '/' car l'idée de type de distingué l'arrivée d'une nouvelle personne a l'entreprise '+' , le départ '-' et la mutation '/'. Puis dans le mutation on trouve ce qu'ont augmentation de salaire donc on le distingue avec changement de NR donc c'est pour il y a '->' .

Suit a votre code il a rien que s'affiche et si je mets '/' il va m'affiché tout çàd dans la colonne NR ce qui sont changées et qui ne sont pas changées , en regardant tableau mvt initial, il y a sur la colonne 2 de type '/' moi par exemple j'ai besoin de copie que la ligne 12 , la ligne 13 j'ai pas besoin alors qu'elle aussi de type '/' je suis bloqué

Le 12/08/2017 à 01:11

Modification du code avec filtrage sur

. colonne 2 non vide : masque "*"

. colonne 14(=NR) contenant "->" : masque "*->*" .

    With Sheets("Mouvements")
        .ListObjects("Tableau22").Range.AutoFilter Field:=2, Criteria1:="*"  'contient quelque chose
         .ListObjects("Tableau22").Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
         .ListObjects("Tableau22").Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A1")
    End With
    With Sheets("Output")
        .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "Tableau22"
        .ListObjects("Tableau22").ShowTotals = True      'affichage ligne Total
    End With
Le 16/08/2017 à 08:45

Toujours pas ne fonctionne pas , il filtre sur la feuille mvt et il ne copie pas sur l'autre feuille

toujours a un problème sur cette ligne

.ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "Tableau22"

Le 16/08/2017 à 11:35

A priori, la copie fonctionnait précédemment. J'ai juste modifié les filtrages. L'autre différence avec le code précédent, c'est la position en A1 et non en A7. Ci-dessous code avec positionnement en A7 sur la feuille "Output":

    With Sheets("Mouvements")
        .ListObjects("Tableau22").Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
        .ListObjects("Tableau22").Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
        .ListObjects("Tableau22").Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A7")
    End With
    With Sheets("Output")
        .ListObjects.Add(xlSrcRange, .Range("A7").CurrentRegion, , xlYes).Name = "Tableau22"
        .ListObjects("Tableau22").ShowTotals = True 'affichage ligne Total
    End With

Si la copie ne s'effectue pas, c'est que la feuille "Output" n'existe pas ou qu'elle est protégée.

Sinon, communiquez-moi un extrait non confidentiel de votre fichier.

Le 16/08/2017 à 13:32

il fonctionne maintenant mais reste lorsque j'ai ajouter autre procédure, donc les données s'écrases et il bugg. Voila code :

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 i As Integer

    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

    Call BigTitle("Suivi Promotions", Ligne, 1)
    Ligne = Ligne + 3

         With Sheets("Mouvements")
        .ListObjects("Tableau22").Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
        .ListObjects("Tableau22").Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
        .ListObjects("Tableau22").Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A7")
    End With
    With Sheets("Output")
        .ListObjects.Add(xlSrcRange, .Range("A7").CurrentRegion, , xlYes).Name = "Tableau22"
        .ListObjects("Tableau22").ShowTotals = True 'affichage ligne Total
    End With

      ' With Sheets("Mouvements")
      '  .ListObjects("Tableau1").Range.AutoFilter Field:=2, Criteria1:="->"  'Filtrage avec ->
      '   .ListObjects("Tableau1").Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A1")
   ' End With
 '   With Sheets("Output")
  '      .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "Tableau1"
   '     .ListObjects("Tableau1").ShowTotals = True      'affichage ligne Total
    ' 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 sans promo"
    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 (Rhubics et Prévisions)", Ligne, 1)    ' Suivi des mutation dans la feuille Suivi des effectifs
        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))
                    '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 = 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
        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"
        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")

        '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
        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"
        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")

       Else
        MsgBox "file does not exist"
    End If
    Set TypesEmb = Nothing
End Sub

j'aimerai bien envoyé une copie de la fichier mais c'est confidentiel

comme je demandé comment faire de sorte que rien s'écrase çàd garder la mise en forme en insérant une ligne après la récupération de tableau avec filtrage

Le 16/08/2017 à 21:00

Pour insérer une ligne après la récupération de tableau avec filtrage, il suffit de rajouter dans la feuille "output" l'instruction suivante :

   .ListObjects("Tableau22").ListRows.Add

donc ci-dessous code ajusté :

    With Sheets("Mouvements")
        .ListObjects("Tableau22").Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
        .ListObjects("Tableau22").Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
        .ListObjects("Tableau22").Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A7")
    End With
    With Sheets("Output")
        .ListObjects.Add(xlSrcRange, .Range("A7").CurrentRegion, , xlYes).Name = "Tableau22"
        .ListObjects("Tableau22").ShowTotals = True 'affichage ligne Total
         .ListObjects("Tableau22").ListRows.Add
    End With
Le 18/08/2017 à 09:59

bonjour,

Ca fonctionne bien maintenant mais toujours les données s'écrases lorsque j'ajoute mon deuxième procédure comme montre la figure:

1223

voila code complète

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 i As Integer

    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

    Call BigTitle("Suivi Promotions", Ligne, 1)
    Ligne = Ligne + 3

     Ligne = Ligne
        Call BigTitle("Promos déja réaliser (Rhubics et Prévisions)", Ligne, 1)    ' Suivi des mutation dans la feuille Suivi des effectifs
        Ligne = Ligne

         With Sheets("Mouvements")
        .ListObjects("Tableau22").Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
        .ListObjects("Tableau22").Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
        .ListObjects("Tableau22").Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A8")
    End With
    With Sheets("Output")
        .ListObjects.Add(xlSrcRange, .Range("A8").CurrentRegion, , xlYes).Name = "Tableau22"
        .ListObjects("Tableau22").ShowTotals = True 'affichage ligne Total
        .ListObjects("Tableau22").ListRows.Add
    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 sans promo"
    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 (Rhubics et Prévisions)", Ligne, 1)    ' Suivi des mutation dans la feuille Suivi des effectifs
       ' 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))
                    '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 = 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
        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"
        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")

        '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
        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"
        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")

       Else
        MsgBox "file does not exist"
    End If
    Set TypesEmb = Nothing
End Sub
Le 18/08/2017 à 12:06

Essayer cette modification avec positionnement du paramètre Ligne de la procédure "Call promoavenir(Ligne)", 2 lignes après la fin du tableau recopié.

    With Sheets("Mouvements")
        With .ListObjects("Tableau22")
            .Range.AutoFilter Field:=2, Criteria1:="*" 'contient quelque chose
             .Range.AutoFilter Field:=14, Criteria1:="*->*" 'contient "->"
             .Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Output").Range("A7")
        End With
    End With
    With Sheets("Output")
        On Error Resume Next
        .ListObjects.Add(xlSrcRange, .Range("A7").CurrentRegion, , xlYes).Name = "Tableau22"
        On Error GoTo 0
        With .ListObjects(1)
            .ShowTotals = True   'affichage ligne Total
             .ListRows.Add        'ajout 1igne vierge
             Ligne = .HeaderRowRange.Row + .ListRows.Count + 3   '2ème ligne libre après tableau
        End With
    End With
Le 18/08/2017 à 13:58

J'ai testé avec votre code je obtient ça :

123333

au niveau titre il créer des colonnes jusqu'à 16383

je ne sais pas pourquoi

Le 18/08/2017 à 14:15

J'ai un autre petit soucis est faire le totale dans ce tableau verticalement

1223333333

ce que je veux :

total

j'essayé comme ça mais ne fonctionne pas comme je veux ;

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 sans promo"
    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 (Rhubics et Prévisions)", Ligne, 1)    ' Suivi des mutation dans la feuille Suivi des effectifs
        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))
                    '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 = 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
        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"
        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")

       'total cologne

          Dim LigneSave As Integer
        For Each key In MutY.Keys
           LigneSave = Ligne
           Range(Cells(Ligne, 1), Cells(Ligne + MutY(key).Count - 1, 1)).Merge
          With Cells(Ligne, 1)
            .Value = key
            .WrapText = True
            .EntireRow.AutoFit
            .VerticalAlignment = xlCenter
          End With
        Next
            Ligne = Ligne + 1

        Dim TV As Integer

        'TV = TableVert(Cells(LigneSave, 1), Cells(Ligne - 1, Names.Count + 6), , , , 0)
        TV = TableVert(Cells(LigneSave, 1), Cells(Ligne - 1, NbPastMonths + 6), , , , 0)
        If MutY.Count <> NbPastMonths 
          Then Call TableVert(Cells(LigneSave, NbPastMonths + 7), Cells(Ligne - 1, MutY.Count + 2), 200, 255, 200, 0)
          Else
            'si une seule équipe, place limitée pour le nom du groupe dans une seule ligne, le compresser
            Cells(LigneSave, 1).Value = Initiales(Cells(LigneSave, 1).Value)
            Rows(Ligne).EntireRow.Hidden = True
        End If
        'total
        Cells(Ligne, 2).Value = "Total"
        For S = 1 To MutY.Count
           'Cells(Ligne, S + 2)  .Value = "=SUM(" & Cells(LigneSave, S + 2).Address & ":" & Cells(Ligne - 1, S + 2).Address & ")"
        Next S
        Call TableVert(Cells(Ligne, 2), Cells(Ligne, MutY.Count + 2), 200, 250, 255, TV)
        Ligne = Ligne + 1

        '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
        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"
        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")
    Else
        MsgBox "file does not exist"
    End If
    Set TypesEmb = Nothing
End Sub

malheureusement j'ai obtient ça

2222222222222
Rechercher des sujets similaires à "copier coller insertion ligne masque lignes vides"