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

[CISCO]

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

 

[job75]

Bonjour CISCO,

Une manière de faire avec cette macro dans le code de la feuille "Résultat" :

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+

 

[pierrejean]

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

 

[job75]

Bonjour Pierre

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)

Bien sûr il ne faut pas toucher à la ligne 6.

A+

 

[job75]

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]

Re,

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

A+

 

[klin89]

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.

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

 

[CISCO]

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]

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"

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]

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]

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]

Bonjour à tous

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

@ plus

 

[pierrejean]

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

 

[CISCO]

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]

Bonsoir à tous,

Cisco : dernière version, j'ai borné la variable b soit le tableau final restitué

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