Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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:
Trier par date Trier par votes

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:
Vote positif 0 Vote négatif

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
Vote positif 0 Vote négatif

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:
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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.
 
Vote positif 0 Vote négatif

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
 

Pièces jointes

  • essai (5).xlsm
    101.7 KB · Affichages: 36
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

R
  • Question
XL 2010 Copier des lignes de données de plusieurs feuilles dans une seule
Réponses
5
Affichages
487
sylvanu
R
  • Question
XL 2010 Copie de données de plusieurs feuilles dans une seule
Réponses
5
Affichages
605
Renaud22
R
G
  • Résolu(e)
Microsoft 365 Consolidation données depuis des feuilles
Réponses
2
Affichages
260
gpion
G
S
  • Question
Microsoft 365 Liaison de données sur deux tableurs
Réponses
6
Affichages
304
JHA
J
M
  • Question
XL 2021 Fusion de lignes
Réponses
3
Affichages
259
vgendron
M
  • Question
XL 2019 Transposer des données d'une feuille vers une autre sous forme de synthèse
Réponses
8
Affichages
262
mromain
T
  • Question
Microsoft 365 Garder les doublons dans une liste déroulante
Réponses
3
Affichages
343
djidji59430
J
  • Résolu(e)
XL 2021 Aide code VBA - à partir de deux listes, créer une base de donnée
2
Réponses
22
Affichages
885
merinos-BernardEtang
O
  • Résolu(e)
XL 2016 Transfert de données sous conditions
Réponses
4
Affichages
500
sylvanu
D
  • Résolu(e)
Microsoft 365 Remplissage colonne automatique dépendant d'un tableau
Réponses
7
Affichages
544
fanfan38
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…