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
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,
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
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
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.
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
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)