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
 

Pièces jointes

  • essai.xlsx
    67.1 KB · Affichages: 71
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+
 

Pièces jointes

  • essai(1).xlsm
    74 KB · Affichages: 50
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
 

Pièces jointes

  • essai (5).xlsm
    97.8 KB · Affichages: 36

klin89

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

klin89

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

Discussions similaires

Réponses
45
Affichages
917

Statistiques des forums

Discussions
311 711
Messages
2 081 786
Membres
101 817
dernier inscrit
carvajal