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

CISCO

XLDnaute Barbatruc
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
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Bonjour CISCO,

Une manière de faire avec cette macro dans le code de la feuille "Résultat" :
Code:
Private Sub Worksheet_Activate()
Dim d As Object, c As Range, f, tablo, ncol%, lig&, col%, moisprec As Byte, j As Variant, dat&, w As Worksheet, i&, k As Variant
Application.ScreenUpdating = False
On Error Resume Next
'---liste des noms---
Set d = CreateObject("Scripting.Dictionary")
For Each c In Sheets("Noms").[C1].CurrentRegion.Resize(, 1)
  d(c.Value) = ""
Next
With Sheets("Résultat")
  .Rows("7:" & .Rows.Count).ClearContents 'RAZ
  .Rows("7:" & .Rows.Count).FormatConditions.Delete 'RAZ MFC
  .[A7].Resize(d.Count) = Application.Transpose(d.keys)
  With .[A6].CurrentRegion
    f = .Rows(1).Formula 'mémorisation des formules
    tablo = .Value2 'matrice, plus rapide
    ncol = UBound(tablo, 2)
    '---remplissage du tableau
    For lig = 2 To d.Count + 1
      For col = 2 To ncol Step 4
        moisprec = 0: j = "x"
1       dat = DateSerial(Year(tablo(1, col)), Month(tablo(1, col)) - moisprec, 1)
        Set w = Nothing
        Set w = Sheets(Format(dat, "mmm"))
        If Not w Is Nothing Then
          For i = 9 To 101 Step 23
            j = Application.Match(tablo(1, col), w.Rows(i), 0)
            If IsNumeric(j) Then
              k = Application.Match(tablo(lig, 1), w.Cells(i + 1, 1).Resize(22), 0)
              If IsNumeric(k) Then
                tablo(lig, col) = w.Cells(i + k, j)
                tablo(lig, col + 1) = w.Cells(i + k, j + 1)
                tablo(lig, col + 2) = w.Cells(i + k, j + 2)
                tablo(lig, col + 3) = w.Cells(i + k, j + 3)
              End If
              Exit For
            End If
          Next i
        End If
        If moisprec = 0 And Not IsNumeric(j) Then moisprec = 1: GoTo 1
    Next col, lig
    '---restitution des valeurs et des formules---
    .Value = tablo
    .Rows(1) = f
    '---MFC---
    With .Rows(2).Resize(d.Count)
      .FormatConditions.Add xlTextString, String:="Repos", TextOperator:=xlContains
      .FormatConditions(1).Interior.ColorIndex = 6 'jaune
    End With
  End With
  Application.Goto .[A1], True 'cadrage
End With
End Sub
A+
 

Fichiers joints

Dernière édition:

pierrejean

XLDnaute Barbatruc
Bonjour Cisco
Salut Gerard (j'ai du faire une fausse manip : après avoir efface quelques cellules de la feuille résultat ta macro n'a plus été efficace)
Pour ma part j'avais pondu ceci :le tableau demandé étant tabres affiché dans la Feuil1 sur activation de la dite feuille
 

Fichiers joints

job75

XLDnaute Barbatruc
Re,

Mais tu as raison, une feuille de mois est à cheval sur 2 mois et ma macro ne traite pas le 2ème mois.

Je vais revoir cela.

A+
 

job75

XLDnaute Barbatruc
Re,

J'ai donc revu la macro de mon post #2 en introduisant la variable moisprec, merci Pierre.

A+
 

klin89

XLDnaute Impliqué
Bonsoir à tous, :)

Je n'ai pas compris s'il fallait restituer le tableau dans son ensemble
je me suis contenté de ventiler les données dans le tableau existant.
VB:
Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, k As Byte, lg As Long, txt As String
Dim ws As Worksheet, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    For Each ws In Worksheets
        If ws.Name <> "Noms" And ws.Name <> "Résultat désiré" Then
            For lg = 9 To 123 Step 23
                a = ws.Range("a" & lg & ": ac" & lg + 22).Value
                For i = 4 To UBound(a, 1)
                    If a(i, 1) <> "" Then
                        For j = 2 To UBound(a, 2) Step 4
                            txt = a(i, 1) & a(1, j)
                            If Not dico.exists(txt) Then
                                ReDim w(1 To 4)
                            Else
                                w = dico.Item(txt)
                            End If
                            For k = 1 To 4
                                w(k) = a(i, j - 1 + k)
                            Next
                            dico.Item(txt) = w
                        Next
                    End If
                Next
            Next
        End If
    Next
    Application.ScreenUpdating = False
    With Sheets("Résultat désiré").Range("a6").CurrentRegion
        With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
            .ClearContents
        End With
        For i = 2 To .Rows.Count
            For j = 2 To .Columns.Count Step 4
                txt = .Cells(i, 1).Value & .Cells(1, j).Value
                If dico.exists(txt) Then
                    With .Cells(i, j).Resize(, 4)
                        .Value = dico.Item(txt)
                    End With
                End If
            Next
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub
klin89
 
Dernière édition:

CISCO

XLDnaute Barbatruc
Bonsoir à tous, bonsoir Job75, Pierrejean et klin89.

Vos propositions semblent fonctionner correctement. Avant de continuer sur l'autre fil, il va surtout falloir que je comprenne vos codes, étape par étape, pour que je puisse les adapter au vrai fichier. Pas évident pour ma petite tête vue mes connaissances en VBA. J'aurai peut être des questions...

Merci et au plaisir.

@ plus
 

klin89

XLDnaute Impliqué
Re Cisco :)

Essaie plutôt ceci :
le tableau est restitué dans son ensemble
j'utilise 2 dictionnaires, le premier pour indexer les lignes, le 2ème pour indexer les colonnes
il faut créer préalablement la feuille "Restitution"
VB:
Option Explicit
Sub test()
Dim a, b(), lg As Long, i As Byte, j As Long, k As Byte, n As Byte, t As Long
Dim ws As Worksheet, dico1 As Object, dico2 As Object
    Set dico1 = CreateObject("Scripting.Dictionary")
    dico1.CompareMode = 1
    Set dico2 = CreateObject("Scripting.Dictionary")
    'attention aux dimensions du tableau restitué <---> b
    ReDim b(1 To 20, 1 To 250)
    n = 1: t = 1
    For Each ws In Worksheets
        If ws.Name <> "Noms" And ws.Name <> "Résultat désiré" Then
            For lg = 9 To 123 Step 23
                a = ws.Range("a" & lg & ": ac" & lg + 22).Value
                For i = 4 To UBound(a, 1)
                    If a(i, 1) <> "" Then
                        If Not dico1.exists(a(i, 1)) Then
                            n = n + 1
                            dico1(a(i, 1)) = n
                            b(n, 1) = a(i, 1)
                        End If
                        For j = 2 To UBound(a, 2) Step 4
                            If Not dico2.exists(a(1, j)) Then
                                If t = 1 Then t = t + 1 Else t = t + 4
                                dico2(a(1, j)) = t
                                For k = 1 To 4
                                    b(1, t - 1 + k) = a(1, j)
                                Next
                            End If
                            For k = 1 To 4
                                b(dico1(a(i, 1)), dico2(a(1, j)) - 1 + k) = a(i, j - 1 + k)
                            Next
                        Next
                    End If
                Next
            Next
        End If
    Next
    Application.ScreenUpdating = False
    With Sheets("Restitution")
        .Cells.Clear
        With .Range("a1").Resize(n, t + 3)
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
                With .Offset(, 1).Resize(, .Columns.Count - 1)
                    .Interior.ColorIndex = 40
                End With
            End With
            With .Columns(1)
                .HorizontalAlignment = xlCenter
                With .Offset(1).Resize(.Rows.Count - 1)
                    .Interior.ColorIndex = 36
                End With
            End With
            With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                .NumberFormat = "h:mm;@"
            End With
        End With
    End With
    Set dico1 = Nothing: Set dico2 = Nothing
    Application.ScreenUpdating = True
End Sub
klin89
 

CISCO

XLDnaute Barbatruc
bonsoir à tous

Merci Klin89 pour cette nouvelle proposition. Je vais essayer de comprendre ta macro, mais il me faudra certainement un peu de temps pour cela... Je reviendrai poser des questions sur ce fil à ce moment là.

@ plus
 

job75

XLDnaute Barbatruc
Bonjour CISCO, le forum,

Je constate que toutes les solutions proposées s'exécutent en quelques centièmes de seconde.

A priori il n'y aura que 12 mois, donc l'exécution se fera en quelques dixièmes de seconde.

Tu peux donc choisir n'importe laquelle des solutions.

Bonne journée.
 

CISCO

XLDnaute Barbatruc
Bonjour à tous

Encore merci Job75. Avant d'utiliser l'une ou l'autre de ces macros, j'essaye surtout de les comprendre.

@ plus
 

pierrejean

XLDnaute Barbatruc
Re
Pour t'aider dans la compréhension j'ai annoté le code
Par ailleurs je suis à ta disposition pour éclaircir tel point qui te parait obscur
 

Fichiers joints

CISCO

XLDnaute Barbatruc
Bonjour

Merci Pierrejean pour ces commentaires dans ton code. Je reviendrai certainement te poser quelques questions sur celui-ci dès que nécessaire.

@plus
 

klin89

XLDnaute Impliqué
Bonsoir à tous, :)

Cisco : dernière version, j'ai borné la variable b soit le tableau final restitué
VB:
Option Explicit
Sub test()
Dim a, b(), lg As Long, i As Byte, j As Long, k As Byte, n As Byte, t As Long
Dim ws As Worksheet, dico1 As Object, dico2 As Object
    Set dico1 = CreateObject("Scripting.Dictionary")
    dico1.CompareMode = 1
    Set dico2 = CreateObject("Scripting.Dictionary")
    For Each ws In Worksheets
        If ws.Name <> "Noms" And ws.Name <> "Résultat désiré" Then
            For lg = 9 To 123 Step 23
                a = ws.Range("a" & lg & ": ac" & lg + 22).Value
                For i = 4 To UBound(a, 1)
                    If a(i, 1) <> "" Then
                        dico1.Item(a(i, 1)) = Empty
                    End If
                Next
                For j = 2 To UBound(a, 2) Step 4
                    If a(1, j) <> "" Then
                        dico2.Item(a(1, j)) = Empty
                    End If
                Next
            Next
        End If
    Next
    ReDim b(1 To dico1.Count + 1, 1 To (dico2.Count * 4) + 1)
    n = 1: t = 1
    For Each ws In Worksheets
        If ws.Name <> "Noms" And ws.Name <> "Résultat désiré" Then
            For lg = 9 To 123 Step 23
                a = ws.Range("a" & lg & ": ac" & lg + 22).Value
                For i = 4 To UBound(a, 1)
                    If a(i, 1) <> "" Then
                        If IsEmpty(dico1.Item(a(i, 1))) Then
                            n = n + 1
                            dico1.Item(a(i, 1)) = n
                            b(n, 1) = a(i, 1)
                        End If
                        For j = 2 To UBound(a, 2) Step 4
                            If IsEmpty(dico2.Item(a(1, j))) Then
                                If t = 1 Then t = t + 1 Else t = t + 4
                                dico2.Item(a(1, j)) = t
                                For k = 1 To 4
                                    b(1, t - 1 + k) = a(1, j)
                                Next
                            End If
                            For k = 1 To 4
                                b(dico1.Item(a(i, 1)), dico2.Item(a(1, j)) - 1 + k) = a(i, j - 1 + k)
                            Next
                        Next
                    End If
                Next
            Next
        End If
    Next
    Application.ScreenUpdating = False
    With Sheets("Résultat désiré")
        .Cells.Clear
        With .Range("a1").Resize(UBound(b, 1), UBound(b, 2))
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
                With .Offset(, 1).Resize(, .Columns.Count - 1)
                    .Interior.ColorIndex = 40
                End With
            End With
            With .Columns(1)
                .HorizontalAlignment = xlCenter
                With .Offset(1).Resize(.Rows.Count - 1)
                    .Interior.ColorIndex = 36
                End With
            End With
            With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                .NumberFormat = "h:mm;@"
            End With
        End With
    End With
    Set dico1 = Nothing: Set dico2 = Nothing
    Application.ScreenUpdating = True
End Sub
klin89
 

job75

XLDnaute Barbatruc
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.
 

Fichiers joints

Dernière édition:

ChTi160

XLDnaute Barbatruc
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

XLDnaute Barbatruc
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
 

Discussions similaires


Haut Bas