XL 2010 VBA : Transfert de données de diverses feuilles à partir de listes différentes

CISCO · 25 Avril 2017

Bonjour à tous

Toujours pour répondre à une demande sur un autre fil, j'essaye de transférer des données contenues dans diverses feuilles vers un tableau avec une macro.

Chaque feuille porte le nom d'un mois. Les données sont regroupées dans des plages représentant les semaines du mois correspondant à la feuille en cours, placées les unes en dessous des autres. Dans la première colonne se trouve le nom des personnes concernées cette semaine là. La liste de ces noms est donnée sur une autre feuille dans la plage Noms!$C$1:$C$25. Chaque mois, la liste des personnes employées, donnée dans la colonne A,peut changer, mais est prise dans cette plage Noms!$C$1:$C$25.

J'aimerai transférer tout cela dans un tableau (Array) en mettant en première ligne les dates (4 cellules par date), et en dessous les données, une ligne par personne employée, comme présenté sur la feuille résultat désiré dans la pièce jointe.

Est-ce que vous avez une solution ?
En vous remerciant d'avance.

@ plus

CISCO · 27 Avril 2017

Bonsoir

Merci klin89. Me reste plus qu'à travailler !

@ plus

job75 · 28 Avril 2017

Bonsoir CISCO, Pierre, klin89,

Toi qui es expert en formules CISCO voici une solution qui devrait te plaire.

Elle consiste à trier à l'aide de formules les tableaux des feuilles des mois pour placer les noms en mêmes positions que dans la feuille "Noms".

Ensuite c'est du "simple" copier-coller :

Code:

Private Sub Worksheet_Activate()
Dim col%, w As Worksheet, i&, P As Range, a$, j%, dates As Range, donnees As Range, n%
Application.ScreenUpdating = False
Rows("6:27").Delete 'RAZ
col = 2
For Each w In Worksheets
  If IsDate("1 " & w.Name) Then
    For i = 9 To 101 Step 23
      '---tris des tableaux pour placer les noms en mêmes positions qu'en feuille "Noms"---
      If i = 9 Then 'il y a des formules de liaisons en A35:A123 !!!
        '---sécurité : recherche des doublons en colonne A du 1er tableau---
        Set P = w.Cells(i + 3, 1).Resize(20): a = P.Address
        P(1, 30).FormulaArray = "=SUM(IF(" & a & "<>0,1/COUNTIF(" & a & "," & a & ")))"
        If P(1, 30) < Application.CountA(P) Then MsgBox "Doublon !!!": Application.Goto w.Cells(i, 1), True: Exit Sub
        '---formules en colonnes AD et AE pour permettre le classement---
        P.Columns(30).FormulaR1C1 = "=MATCH(RC1,Noms,0)"
        a = P.Columns(30).Address(, , xlR1C1)
        P(1, 31).FormulaArray = _
        "=IF(ISNUMBER(RC30),RC30,MIN(IF(NOT(COUNTIF(" & a & ",ROW(R1:R20))+COUNTIF(R" & i + 2 & "C:R[-1]C,ROW(R1:R20))),ROW(R1:R20))))"
        P(1, 31).AutoFill P.Columns(31) 'tire la formule matricielle vers le bas
        P.Columns(30).Resize(, 2) = P.Columns(30).Resize(, 2).Value 'supprime les formules
        '---tris---
        For j = 1 To 4 'pour les 4 autres tableaux
          P.Columns(30).Offset(23 * j) = P.Columns(31).Value 'colonnes AD des 4 autres tableaux
          P.Columns(2).Offset(23 * j).Resize(, 29).Sort P(1, 30), xlAscending, Header:=xlNo 'tri des colonnes B:AD sur AD
        Next j
        P.Resize(, 31).Sort P(1, 31), xlAscending, Header:=xlNo 'tri du 1er tableau sur la colonne AE
        w.Columns(30).Resize(, 2).ClearContents 'RAZ des colonnes auxiliaires AD et AE
      End If
      '---copie les dates et leurs données seulement s'il y a des données---
      Set dates = Nothing: Set donnees = Nothing: n = 0
      For j = 2 To 26 Step 4
        If Application.CountA(w.Cells(i + 3, j).Resize(20, 4)) Then
          Set dates = Union(w.Cells(i, j).Resize(, 4), IIf(n, dates, w.Cells(i, j).Resize(, 4)))
          Set donnees = Union(w.Cells(i + 3, j).Resize(20, 4), IIf(n, donnees, w.Cells(i + 3, j).Resize(20, 4)))
          n = n + 4
        End If
      Next j
      If n Then
        dates.Copy 'copie groupée des dates
        Cells(6, col).PasteSpecial xlPasteValues 'collage spécial valeurs
        Cells(6, col).PasteSpecial xlPasteFormats 'collage spécial formats
        For j = 0 To n - 4 Step 4
          Cells(6, col + j).UnMerge 'défusionne la cellule
          Cells(6, col + j).Resize(, 4).HorizontalAlignment = xlCenterAcrossSelection 'centre sur 4 colonnes
          Cells(27, col + j).Resize(, 4) = Cells(6, col + j) '4 fois la date pour le tri horizontal final
        Next j
        donnees.Copy Cells(7, col) 'copie groupée des données
        col = col + n
      End If
    Next i
  End If
Next w
If col > 2 Then Range(Cells(6, 2), Cells(27, col - 2)).Sort Rows(27), xlAscending, Orientation:=xlLeftToRight 'tri horizontal par date
[Noms].Resize(20).Copy [A7] 'copie la liste des noms (limitée à 20 noms)
i = Range("A" & Rows.Count).End(xlUp).Row 'dernière ligne
If i < 6 Then i = 6
Rows(i + 1 & ":27").Delete
Application.Goto [A1], True 'cadrage
End Sub

Edit : j'ai revu la macro car je n'avais pas vu les formules de liaison en A35:A123 des feuilles de mois !!!

Pour voir les formules du 1er tableau en colonnes AD et AE insérer un End après la ligne de l'AutoFill.

L'avantage de cette solution c'est que les données sont copiées avec leurs formats.

L'inconvénient c'est que cela prend plus de temps.

Pour les 2 feuilles de mois la durée d'exécution est de 0,17 seconde chez moi, ce qui donnera 1 seconde pour 12 mois, cela paraît encore acceptable non ?

Fichier (2).

Bonne nuit.

mapomme · 28 Avril 2017

Bonjour à tous ,

Juste une version de mapomme qui n'apporte aucune originalité si ce n'est que le code est (un peu) commenté.

ChTi160 · 28 Avril 2017

Bonjour CISCO
Bonjour le Fil ,Le Forum
j'ai constaté , en feuille Résultat de la dernière version de Job75 , qu'il manquait , les 2,3,4 décembre après report .
Merci Job75
Bonne journée
Amicalement
Jean Marie

CISCO · 28 Avril 2017

Bonjour à tous

Merci Job75 et mapomme pour ces nouvelles versions. En regardant les codes en diagonale (pour le moment), j'y vois plein de petites astuces qui me plaisent bien, du style If Isdate ("1 " & w.name) then...

Pas mal, d'un point de vue pédagogique, de passer par un classement des noms, même si cela met un petit peu plus de temps.

Pour ce qui est des commentaires, mapomme, ne "t'inquiètes" pas, il y en a déjà pas mal comme ça. La méthode est très bien expliquée.

Encore une fois, merci à tous.

@ plus

job75 · 28 Avril 2017

Bonjour CISCO, le forum,

ChTi160 à dit:
j'ai constaté , en feuille Résultat de la dernière version de Job75 , qu'il manquait , les 2,3,4 décembre après report .

Pourquoi crois-tu que je mets des commentaires

'---copie les dates et leurs données seulement s'il y a des données---

J'en ai profité pour ajouter la recherche des doublons dans le fichier (2).

Bonne journée.

ChTi160 · 28 Avril 2017

Oupss excuses !! Logique

job75 · 28 Avril 2017

Re,

CISCO à dit:
Pas mal, d'un point de vue pédagogique, de passer par un classement des noms, même si cela met un petit peu plus de temps.

Sur le fichier(2) les copier-coller prennent 0,10 seconde, les formules pour le classement 0,05 seconde.

A+

mapomme · 28 Avril 2017

Bonjour à tous,

Comme on est passé avec la contrainte de recopie du format, voici une version v2.
Le but était de partir de la v1 et de la modifier le moins possible (ce qui peut nuire à la durée d'exécution - le code de la v1 n'étant pas fait pour - mais économise du temps de codage). Dans le code, les lignes modifiées, sont repérées par le commentaire '*** en bout ligne. Je ne modifie pas les feuilles sources.

Le principe est que dans le tableau res, on ne stocke plus la valeur de la cellule source mais son adresse. Ensuite une fois le tableau res inscrit sur la feuille, on copie (grâce à l'adresse) la cellule source avec son tout son format sur la cellule contenant cette adresse source.

Sur mon antique micro (mai 2007), la durée est d'env. 1,5 sec. (10 fois plus long que job75 ) pour les deux feuilles mois.

job75 · 29 Avril 2017

Bonjour CISCO, le forum, salut mapomme,

Je n'avais pas vu qu'il y a des formules de liaison en A35:A123 des feuilles de mois !!!

Du coup la macro de mon post #17 - fichier (2) - n'allait pas du tout, j'ai du revoir les tris des tableaux.

Cela divise par 5 le temps de calcul des formules.

Bonne journée.

job75 · 30 Avril 2017

Bonjour CISCO, le forum,

Si l'on craint que des données soient entrées par erreur sur des lignes sans nom :

Code:

Private Sub Worksheet_Activate()
Dim col%, w As Worksheet, i&, P As Range, a$, j%, dates As Range, donnees As Range, n%
Application.ScreenUpdating = False
Rows("6:27").Delete 'RAZ
col = 2
For Each w In Worksheets
  If IsDate("1 " & w.Name) Then
    For i = 9 To 101 Step 23
      '---tris des tableaux pour placer les noms en mêmes positions qu'en feuille "Noms"---
      If i = 9 Then 'il y a des formules de liaisons en A35:A123 !!!
        '---sécurité : recherche des doublons en colonne A du 1er tableau---
        Set P = w.Cells(i + 3, 1).Resize(20): a = P.Address
        P(1, 30).FormulaArray = "=SUM(IF(" & a & "<>0,1/COUNTIF(" & a & "," & a & ")))"
        If P(1, 30) < Application.CountA(P) Then MsgBox "Doublon !!!": Application.Goto w.Cells(i, 1), True: Exit Sub
        '---formules en colonnes AD et AE pour permettre le classement---
        P.Columns(30).FormulaR1C1 = "=MATCH(RC1,Noms,0)"
        a = P.Columns(30).Address(, , xlR1C1)
        P(1, 31).FormulaArray = _
        "=IF(ISNUMBER(RC30),RC30,MIN(IF(NOT(COUNTIF(" & a & ",ROW(R1:R20))+COUNTIF(R" & i + 2 & "C:R[-1]C,ROW(R1:R20))),ROW(R1:R20))))"
        P(1, 31).AutoFill P.Columns(31) 'tire la formule matricielle vers le bas
        P.Columns(30).Resize(, 2) = P.Columns(30).Resize(, 2).Value 'supprime les formules
        '---tris---
        For j = 1 To 4 'pour les 4 autres tableaux
          P.Columns(30).Offset(23 * j).Resize(, 2) = P.Columns(30).Resize(, 2).Value 'colonnes AD:AE des 4 autres tableaux
          P.Columns(2).Offset(23 * j).Resize(, 30).Sort P(1, 31), xlAscending, Header:=xlNo 'tri des colonnes B:AE sur AE
        Next j
        P.Resize(, 31).Sort P(1, 31), xlAscending, Header:=xlNo 'tri du 1er tableau sur la colonne AE
        '---effacement des données entrées par erreur sur des lignes sans nom---
        On Error Resume Next 'si aucune SpecialCells
        Intersect(w.Columns(2).Resize(, 28), w.Columns(30).SpecialCells(xlCellTypeConstants, 16).EntireRow) = ""
        On Error GoTo 0
        w.Columns(30).Resize(, 2).ClearContents 'RAZ des colonnes auxiliaires AD et AE
      End If
      '---copie les dates et leurs données seulement s'il y a des données---
      Set dates = Nothing: Set donnees = Nothing: n = 0
      For j = 2 To 26 Step 4
        If Application.CountA(w.Cells(i + 3, j).Resize(20, 4)) Then
          Set dates = Union(w.Cells(i, j).Resize(, 4), IIf(n, dates, w.Cells(i, j).Resize(, 4)))
          Set donnees = Union(w.Cells(i + 3, j).Resize(20, 4), IIf(n, donnees, w.Cells(i + 3, j).Resize(20, 4)))
          n = n + 4
        End If
      Next j
      If n Then
        dates.Copy 'copie groupée des dates
        Cells(6, col).PasteSpecial xlPasteValues 'collage spécial valeurs
        Cells(6, col).PasteSpecial xlPasteFormats 'collage spécial formats
        For j = 0 To n - 4 Step 4
          Cells(6, col + j).UnMerge 'défusionne la cellule
          Cells(6, col + j).Resize(, 4).HorizontalAlignment = xlCenterAcrossSelection 'centre sur 4 colonnes
          Cells(27, col + j).Resize(, 4) = Cells(6, col + j) '4 fois la date pour le tri horizontal final
        Next j
        donnees.Copy Cells(7, col) 'copie groupée des données
        col = col + n
      End If
    Next i
  End If
Next w
If col > 2 Then Range(Cells(6, 2), Cells(27, col - 2)).Sort Rows(27), xlAscending, Orientation:=xlLeftToRight 'tri horizontal par date
[Noms].Resize(20).Copy [A7] 'copie la liste des noms (limitée à 20 noms)
i = Range("A" & Rows.Count).End(xlUp).Row 'dernière ligne
If i < 6 Then i = 6
Rows(i + 1 & ":27").Delete
Application.Goto [A1], True 'cadrage
End Sub

Fichier (3), la durée d'exécution de la macro n'est pratiquement pas augmentée.

Bon dimanche.

XL 2010 VBA : Transfert de données de diverses feuilles à partir de listes différentes

CISCO

XLDnaute Barbatruc

Pièces jointes

CISCO

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

ChTi160

XLDnaute Barbatruc

CISCO

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires