Tableau VBA

Bonjour à toutes et à tous,

Pour commencer, je vous souhaite mes meilleurs vœux pour cette nouvelle année 2020.

Je vous sollicite car je suis coincé sur une macro, peut être que je procède mal pour celle-ci. J'avais crée un macro afin de boucler sur une base de données (appelée PLANNING 2020 dans le fichier ci-joint) pour la transformer en tableau afin d'en faire un ou plusieurs TCD. Le résultat se rapportant dans l'onglet "Table". Là, pas de soucis, tout fonctionne bien.

La base de données est amener à évoluer en ajoutant des colonnes (appelée PLANNING 2020B dans le fichier). J'ai essayé d'adapter ma macro pour ajouter une boucle et avoir le résultat dans "Table2") là je me retrouve avec un problème de mémoire insuffisante. Ça ne fonctionne plus. Si vous avez une idée... Merci d'avance pour votre aide.

Voici les macro :

Macro qui fonctionne

Public Sub Create_Table()
Dim wb As Workbook
Dim wsData As Worksheet, wsTable As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim tbl, Arr()
Dim I As Long, J As Long, k As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("PLANNING 2020")
    Set wsTable = wb.Worksheets("Table")
    Set lo = wsTable.ListObjects(1)

    With lo
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        Set Cell = .InsertRowRange.Cells(1)
    End With

    tbl = wsData.Cells(1).CurrentRegion.Value
    For I = 2 To UBound(tbl)
        For J = 13 To UBound(tbl, 2)
            If tbl(I, J) <> "" Then
                ReDim Preserve Arr(12, k + 1)
                Arr(0, k) = tbl(I, 1)
                Arr(1, k) = tbl(I, 2)
                Arr(2, k) = tbl(I, 3)
                Arr(3, k) = tbl(I, 4)
                Arr(4, k) = tbl(I, 5)
                Arr(5, k) = tbl(I, 6)
                Arr(6, k) = tbl(I, 7)
                Arr(7, k) = tbl(I, 8) & ", " & tbl(I, 9)
                Arr(8, k) = tbl(I, 10)
                Arr(9, k) = tbl(I, 11)
                Arr(10, k) = tbl(I, 12)
                Arr(11, k) = CLng(tbl(1, J))
                Arr(12, k) = tbl(I, J)
                k = k + 1
            End If
        Next J
    Next I

    If k > 0 Then Cell.Resize(k, 13).Value = Application.Transpose(Arr)
    lo.HeaderRowRange.EntireColumn.AutoFit

Macro qui fonctionne pas

Public Sub Create_Table2()
Dim wb As Workbook
Dim wsData As Worksheet, wsTable As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim tbl, Arr()
Dim I As Long, J As Long, k As Long, Q As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("PLANNING 2020B")
    Set wsTable = wb.Worksheets("Table2")
    Set lo = wsTable.ListObjects(1)

    With lo
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        Set Cell = .InsertRowRange.Cells(1)
    End With

    tbl = wsData.Cells(1).CurrentRegion.Value
    For I = 2 To UBound(tbl)
      For Q = 11 To 20
        For J = 22 To UBound(tbl, 2)
            If tbl(I, J) <> "" Then
                ReDim Preserve Arr(13, k + 1)
                Arr(0, k) = tbl(I, 1)
                Arr(1, k) = tbl(I, 2)
                Arr(2, k) = tbl(I, 3)
                Arr(3, k) = tbl(I, 4)
                Arr(4, k) = tbl(I, 5)
                Arr(5, k) = tbl(I, 6)
                Arr(6, k) = tbl(I, 7)
                Arr(7, k) = tbl(I, 8) & ", " & tbl(I, 9)
                Arr(8, k) = tbl(I, 10)
                Arr(9, k) = tbl(1, Q)
                Arr(10, k) = tbl(I, Q)
                Arr(11, k) = tbl(I, 21)
                Arr(12, k) = CLng(tbl(1, J))
                Arr(13, k) = tbl(I, J)
                k = k + 1
            End If
        Next J
      Next Q
    Next I

    If k > 0 Then Cell.Resize(k, 14).Value = Application.Transpose(Arr)
    lo.HeaderRowRange.EntireColumn.AutoFit

End Sub
13excelpratique.xlsm (441.99 Ko)

Salut

Meilleurs vœux à toi aussi.

Quel est ton objectif exactement. Remplir la colonne compétence de la table2 à partir des colonnes K à T de Planning 2020B ?

Jers

Bonjour Jers et merci de ta réponse.

Oui c'est bien ça, remplir la colonne compétences en fonction des colonnes K à T et la colonne Valeur en fonction des mêmes valeurs.

En fait obtenir ça.

table excel pratique

Bonjour,

Je connais cette procédure !...

Pourquoi ne pas traiter tes données avec Power Query ?

Il y une requête dans ton classeur !?

Power Query est à privilégier pour nettoyer les données (Crap data).

Cdlt.

Bonjour Jean Eric.

Et oui, la solution Power Qerry serait la plus aisée, et c'est sûr ça solutionne tout mon problème.

Mais, car il y a un mais , les collaborateurs pour qui je travaille non pas Power Querry, ça ne sera pas installé par la DSI actuelle (du moins pas de suite) et donc impossible pour eux de mettre à jour la requête.

D'où ma problématique vba

Salut,

Je te propose cela

For I = 2 To UBound(tbl)
        For J = 22 To UBound(tbl, 2)
            ListeCompetence = ""
            If tbl(I, J) <> "" Then
                ReDim Preserve Arr(13, k + 1)
                Arr(0, k) = tbl(I, 1)
                Arr(1, k) = tbl(I, 2)
                Arr(2, k) = tbl(I, 3)
                Arr(3, k) = tbl(I, 4)
                Arr(4, k) = tbl(I, 5)
                Arr(5, k) = tbl(I, 6)
                Arr(6, k) = tbl(I, 7)
                Arr(7, k) = tbl(I, 8) & ", " & tbl(I, 9)
                Arr(8, k) = tbl(I, 10)
                For Q = 11 To 20
                    If UCase(tbl(I, Q)) = "X" Then
                        If ListeCompetence = "" Then
                            ListeCompetence = tbl(1, Q)
                        Else
                            ListeCompetence = ListeCompetence & ";" & tbl(1, Q)
                        End If
                    End If
                Next Q
                Arr(9, k) = ListeCompetence
                Arr(10, k) = "X"
                Arr(11, k) = tbl(I, 21)
                Arr(12, k) = CLng(tbl(1, J))
                Arr(13, k) = tbl(I, J)
                k = k + 1
            End If
        Next J
    Next I

Il faut ajouter la déclaration

Dim ListeCompetence$

Par contre, je n'ai pas compris à quoi servait la colonne k (valeur) dans table2, j'ai mis "X" par défaut.

Jers

Merci pour ta proposition Jers, même si celle-ci ne me fait pas aboutir à ce que je recherche, elle m'a donné des pistes de réflexion.

Pour répondre à ta question, la colonne valeurs dans la table en exemple, celle-ci me sort les résultats si la compétence est acquise ou non (les X dans les lignes du Planning).

En adaptant un peu à partir de ce que tu proposes, j'arrive à une partie du résultat voulu en mettant ce code :

Public Sub Create_Table2()
Dim wb As Workbook
Dim wsData As Worksheet, wsTable As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim tbl, Arr()
Dim I As Long, J As Long, k As Long, Q As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("PLANNING 2020B")
    Set wsTable = wb.Worksheets("Table2")
    Set lo = wsTable.ListObjects(1)

    With lo
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        Set Cell = .InsertRowRange.Cells(1)
    End With

    tbl = wsData.Cells(1).CurrentRegion.Value
      For I = 2 To UBound(tbl)
        For J = 22 To UBound(tbl, 2)
            If tbl(I, J) <> "" Then
                ReDim Preserve Arr(13, k + 1)
                Arr(0, k) = tbl(I, 1)
                Arr(1, k) = tbl(I, 2)
                Arr(2, k) = tbl(I, 3)
                Arr(3, k) = tbl(I, 4)
                Arr(4, k) = tbl(I, 5)
                Arr(5, k) = tbl(I, 6)
                Arr(6, k) = tbl(I, 7)
                Arr(7, k) = tbl(I, 8) & ", " & tbl(I, 9)
                Arr(8, k) = tbl(I, 10)
                For Q = 11 To 20
                  Arr(9, k) = tbl(1, Q)
                  Arr(10, k) = tbl(I, Q)
                Next Q
                Arr(11, k) = tbl(I, 21)
                Arr(12, k) = CLng(tbl(1, J))
                Arr(13, k) = tbl(I, J)
                k = k + 1

            End If
        Next J
    Next I

    If k > 0 Then Cell.Resize(k, 14).Value = Application.Transpose(Arr)
    lo.HeaderRowRange.EntireColumn.AutoFit

End Sub

Néanmoins, un soucis, en entrant le code comme ça, ça me sort uniquement les résultats de la colonne 20, et manque au final les résultats des colonnes 11 à 19, comme s'il ne bouclait pas sur le tout....

Ca cest normal car tu boucles de 11 à 20 mais avec la même valeur de k, donc il ne garde que la dernière à savoir 20.

Par contre. Peux tu m'expliquer pourquoi ma proposition ne convient pas. Tu veux faire une ligne par compétence ?

Ce n'est pas que la solution ne convient pas (terme un peu fort ), elle n'aboutit pas (encore ? )au résultat attendu. En effet, j'aimerai une compétence par ligne, comme le montre la copie d'écran ci-dessous pour le résultat avec ma boucle sans k et pour laquelle je metire les cheveux depuis ton message...

resultats excel pratique

Donc si pour une ligne dans planning2020b tu as 5 compétences et 5 dates, tu veux 10 lignes dans table 2 ? Si oui pas de pb je te l'envoie ce soir

Oui, en effet c'est bien cela que je recherche.

En adaptant à nouveau le code comme ci-dessous, j'arrive à faire ce que je veux, mais sur le fichier réduit fourni. Sur la base de plus de 100 collaborateurs, là je me retrouve avec l'erreur de mémoire insuffisante....

Donc si tu as la solution, effectivement je serai preneur

Public Sub Create_Table2()
Dim wb As Workbook
Dim wsData As Worksheet, wsTable As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim tbl, Arr()
Dim I As Long, J As Long, k As Long, Q As Long, l As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("PLANNING 2020B")
    Set wsTable = wb.Worksheets("Table2")
    Set lo = wsTable.ListObjects(1)

    With lo
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        Set Cell = .InsertRowRange.Cells(1)
    End With

    tbl = wsData.Cells(1).CurrentRegion.Value
      For I = 2 To UBound(tbl)
        For J = 22 To UBound(tbl, 2)
            If tbl(I, J) <> "" Then
              For Q = 11 To 20
                ReDim Preserve Arr(13, k + 1)
                Arr(0, k) = tbl(I, 1)
                Arr(1, k) = tbl(I, 2)
                Arr(2, k) = tbl(I, 3)
                Arr(3, k) = tbl(I, 4)
                Arr(4, k) = tbl(I, 5)
                Arr(5, k) = tbl(I, 6)
                Arr(6, k) = tbl(I, 7)
                Arr(7, k) = tbl(I, 8) & ", " & tbl(I, 9)
                Arr(8, k) = tbl(I, 10)
                Arr(9, k) = tbl(1, Q)
                Arr(10, k) = tbl(I, Q)
                Arr(11, k) = tbl(I, 21)
                Arr(12, k) = CLng(tbl(1, J))
                Arr(13, k) = tbl(I, J)
                k = k + 1
                Next Q
            End If
        Next J
    Next I

    If k > 0 Then Cell.Resize(k, 14).Value = Application.Transpose(Arr)
    lo.HeaderRowRange.EntireColumn.AutoFit

End Sub

Tu peux m'envoyer le fichier complet avec ton code maj pour que je teste

Compliqué de t’envoyer le tableau en entier, vu que c’est données internes et confidentielles à l’entreprise. L’onglet planning comporte 110 lignes pour être exact

Bonjour,

Un essai.

Attention au format de la date !...

Procédure CreateTable2().

Cdlt.

6excelpratique.xlsm (394.78 Ko)

Bonjour Jean Eric,

Merci pour ta proposition. J'ai pris le temps de regarder ce matin, en adaptant un peu j'obtiens ce que je veux. Merci pour cette aide.

Néanmoins, en testant sur le fichier plus complet, en voulant aussi les lignes de compétences vides, je me retrouve à nouveau avec l'erreur mémoire insuffisante.

Afin de pouvoir vous rendre compte plus réellement, je joins le fichier complet vidé d'informations confidentielles.

Bonjour,

Gérer les vides ?

Te rends -tu compte du nombre de lignes ?

Une mise à jour de la proposition.

A tester…

Cdlt.

Public Sub Create_Table2()
Dim wb As Workbook
Dim wsData As Worksheet, wsTable As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim tbl, Arr()
Dim I As Long, J As Long, K As Long, m As Long
Dim modCalc As Long

    With Application
        .ScreenUpdating = False
        modCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("PLANNING 2020")
    Set wsTable = wb.Worksheets("Table")
    Set lo = wsTable.ListObjects(1)

    With lo
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        Set Cell = .InsertRowRange.Cells(1)
    End With

    tbl = wsData.Cells(1).CurrentRegion.Value
    For I = 2 To UBound(tbl)
        For J = 11 To 20
            For K = 22 To UBound(tbl, 2)
                If m > 15000 Then
                    Cell.Resize(m, 14).Value = Application.Transpose(Arr)
                    Set Cell = lo.HeaderRowRange.Cells(1).Offset(lo.ListRows.Count + 1)
                    m = 0
                End If
                ReDim Preserve Arr(14, m + 1)
                Arr(0, m) = tbl(I, 1)
                Arr(1, m) = tbl(I, 2)
                Arr(2, m) = tbl(I, 3)
                Arr(3, m) = tbl(I, 4)
                Arr(4, m) = tbl(I, 5)
                Arr(5, m) = tbl(I, 6)
                Arr(6, m) = tbl(I, 7)
                Arr(7, m) = tbl(I, 8) & ", " & tbl(I, 9)
                Arr(8, m) = tbl(I, 10)
                Arr(9, m) = tbl(1, J)           'competence
                Arr(10, m) = tbl(I, J)
                Arr(11, m) = tbl(I, 21)         'rotation
                Arr(12, m) = tbl(1, K)         'date
                Arr(13, m) = tbl(I, K)           'valeur
                m = m + 1
            Next K
        Next J
    Next I

    Cell.Resize(m, 14).Value = Application.Transpose(Arr)
    lo.HeaderRowRange.EntireColumn.AutoFit

    Application.Calculation = modCalc

End Sub

bonjour Jean Eric,

Effectivement je me rends et me rendais compte du nombre de lignes à générer.

Je viens de tester ta solution en dur sur le fichier original et ça fonctionne. J'en suis à 45 secondes d’exécution pour la macro, ça pose pas de problème , c'est pour info.

En tout cas merci, je n'avais pas pensé à enlever puis remettre le calcul automatique ni à gérer le nombre de lignes en variable. Merci beaucoup aussi pour le temps passé sur ce sujet (ainsi qu'à Jers)

Rechercher des sujets similaires à "tableau vba"