Macro avec utilisation de tableau
Bonjour à tous,
Je vais essayer d'énumérer clairement ma demande, mais si ce n'est pas le cas, n'hésitez pas à me le dire pour que je clarifie.
J'ai un tableau de données (tableau receveur) avec un grand nombre de colonnes où chaque ligne a une référence unique. Je souhaite pouvoir mettre les données de ce tableau à jour à partir d'un autre tableau (tableau donneur, avec les mêmes colonnes) via une macro utilisant des tableaux.
Pour information, j'ai déjà une macro qui peut le faire sans utiliser les tableaux dans VBA mais qui prend pas mal de temps. J'ai également d'autres applications de cette macro dans des cas plus complexes (et qui prennent encore plus de temps), d'où mon souhait de pouvoir créer une nouvelle macro exploitant les tableaux.
A savoir que dans le tableau donneur:
- Il peut y avoir de nouvelles références initialement absentes du tableau receveur, que je dois alors ajouter dans le tableau receveur
- Il peut ne pas y avoir certaines références du tableau receveur, et je dois alors les supprimer dans le tableau receveur.
A savoir que dans les deux tableaux, les colonnes dont les informations me sont nécessaires se retrouvent dans le même ordre; mais dans mon tableau receveur, j'ai quelques colonnes supplémentaires en début de tableau dans lesquelles j'ai des formules qui me permettent de filtrer mes données.
Exemple de tableau simplifié en pièce jointe.
Je pense être sur une bonne piste pour la mise à jour des références communes entre le donneur et le receveur (voir ci-dessous) mais je bloque un peu pour les données à ajouter ou à supprimer (j'ai tenté avec le redimensionnement de tableau mais appris à mes dépens que le contenu n'est pas alors pas conservé).
Auriez-vous des pistes que je pourrais explorer pour réaliser cela s'il vous plait?
For i = 1 To UBound(arr_gv(), 1) Step 1 'On parcourt chaque ligne du tableau donneur
bool = False 'J'ai mis un bool pour identifier les cas où pas de correspondance
For j = 1 To UBound(arr_rc(), 1) Step 1 'On parcourt chaque ligne du receveur
If arr_gv(i, 1) = arr_rc(j, 9) Then 'et on vérifie si la référence existe
arr_rc(j, 1) = today 'Si oui, on encode au début de la ligne la date du jour (= date de mise à jour) For k = 1 To 45 ' et on met les données à jour
arr_rc(j, k + 8) = arr_gv(i, k)
Next k
bool = True 'et le bool passe en True
Exit For
End If
Next j
Next iBonjour Thomas et
Une petite présentation ICI serait la bienvenue
Si vous ne l'avez pas encore fait, je vous invite à lire :
- La charte du forum
- Quelques fonctionnalités du forum à connaître
Regardez aussi les petites icônes mises à votre disposition dans la barre de menu qui :
- vous permettent de poster un code (</>)
- ou de clôturer un fil lorsque vous avez terminé (V)
Concernant votre demande, si c'est juste pour une consultation, pourquoi ne pas faire ça avec Power Query ?
Merci pour votre participation
Cordialement
Merci :-)
Concernant votre demande, si c'est juste pour une consultation, pourquoi ne pas faire ça avec Power Query ?
Pour la bonne et simple raison que je n'y connais rien en power query :-p (je me le note dans les sujets à découvrir lorsque j'aurai un peu de temps ^^)
Mais mon tableau receveur va au-delà de la consultation. Je l'utilise également comme Action Log avec des colonnes "libres" où je peux entrer une action et une due date.
Bonsoir à tous,
Thomas, c'est ça que tu veux obtenir dans la feuille Receveur ?
Option Explicit
Sub Comparaison1()
Dim a, i As Long, j As Long, dico As Object
Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Donneur").Cells(1).CurrentRegion
For i = 1 To .Rows.Count
dico(.Cells(i, 1).Value) = .Rows(i).Value
Next
End With
With Sheets("Receveur").Cells(1).CurrentRegion
.Offset(, .Columns.Count + 1).EntireColumn.Clear
With .Offset(, 3).Resize(, .Columns.Count - 3)
For i = 1 To .Rows.Count
If dico.exists(.Cells(i, 1).Value) Then
.Rows(i).Offset(, .Columns.Count + 1).Value = dico(.Cells(i, 1).Value)
dico.Remove .Cells(i, 1).Value
End If
Next
End With
If dico.Count > 0 Then
With .Offset(.Rows.Count + 1, .Columns.Count + 1).Resize(dico.Count, .Columns.Count - 3)
.Value = Application.Transpose(Application.Transpose(dico.items))
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
End With
End If
With .Offset(, .Columns.Count + 1).Resize(, .Columns.Count - 3).EntireColumn
With .Rows(1)
.Interior.ColorIndex = 36
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
End With
.Font.Name = "calibri"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Columns.AutoFit
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Oui effectivement c'est vers cela que ça doit tendre.
Par contre, je ne connais pas du tout le genre de fonctions que tu as utilisé dans ton code. Je m'en vais potasser tout ça pour m'assurer que cela fonctionne correctement.
Merci pour le partage :-)
re Thomas,
Essaie ceci sur une copie de la feuille "Receveur"
Attention au nom de la feuille dans le code.
Option Explicit
Sub mise_a_jour()
Dim a, i As Long, x As Range, dico As Object
Application.ScreenUpdating = False
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Donneur").Cells(1).CurrentRegion.Columns(1).Value
For i = 2 To UBound(a, 1)
dico(a(i, 1)) = i
Next
With Sheets("Receveur")
a = .Cells(1).CurrentRegion.Columns(4).Value
For i = 2 To UBound(a, 1)
If dico.exists(a(i, 1)) Then
Sheets("Donneur").Rows(dico(a(i, 1))).Resize(, 7).Copy .Cells(i, 4).Resize(, 7)
.Cells(i, 1).Value = Date
dico.Remove a(i, 1)
Else
If x Is Nothing Then
Set x = .Rows(i)
Else
Set x = Union(x, .Rows(i))
End If
End If
Next
If dico.Count Then
For i = 0 To dico.Count - 1
Sheets("Donneur").Rows(dico.items()(i)).Resize(, 7).Copy _
Destination:=.Range("d" & Rows.Count).End(xlUp)(2)
.Range("a" & Rows.Count).End(xlUp)(2) = Date
Next
End If
If Not x Is Nothing Then x.EntireRow.Delete
End With
Set x = Nothing
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89