reprendre les dates contenues dans une liste pour les mettre dans un tablau

[pascal21]

bonjour à tous
j'ai une liste de véhicules avec les dates de différentes operations à réalisées (controle technique, entretien, etc...) que j'ai appelé A B C D E F dans l'exemple joint pour simplifier
j'aimerais intégrer ces données sous forme de tableau (feuil1) pour avoir un visuel plus confortable
il s'agirait d'indiquer l'immat. du véhicule
soit sous forme de commentaire dans les cellules concernées (solution que je retiens en priorité) soit sous forme classique dans les cellules
voir le fichier joint
merci de votre aide

 

[job75]

Re : reprendre les dates contenues dans une liste pour les mettre dans un tablau

Bonjour pascal21,

Voir le fichier joint avec cette macro :

Sub Immatriculations()
Dim plage1 As Range, plage2 As Range, rc&, i&, j As Byte, k&, im$
Set plage1 = Feuil1.Range("B5:G" & Feuil1.[A65536].End(xlUp).Row)
Set plage2 = Feuil2.Range("F5:K" & Feuil2.[E65536].End(xlUp).Row)
rc = plage2.Rows.Count
Application.ScreenUpdating = False
plage1.ClearContents 'RAZ
For i = 1 To plage1.Rows.Count
  For j = 1 To 6
    im = ""
    For k = 1 To rc
      If plage1(i, 0) <> "" And _
        plage1(i, 0) = plage2(k, j) Then _
          im = im & vbLf & plage2(k, 0)
    Next
    If im <> "" Then plage1(i, j) = Mid(im, 2)
  Next
Next
plage1.WrapText = True 'renvoi à la ligne
plage1.Rows.AutoFit 'ajustement automatique
End Sub

Edit : avec If im <> "" Then c'est plus rapide.

A+

 

[job75]

Re : reprendre les dates contenues dans une liste pour les mettre dans un tablau

Re,

S'il y a un très grand nombre de lignes il vaut mieux utiliser cette macro :

Sub Immatriculations()
Dim col1, col2, ub&, tablo1, tablo2, i&, d, j As Byte, im$, k&
col1 = Feuil1.Range("A5", Feuil1.[A65536].End(xlUp))
col2 = Feuil2.Range("E5", Feuil2.[E65536].End(xlUp))
ub = UBound(col2)
ReDim tablo1(1 To UBound(col1), 1 To 6)
tablo2 = Feuil2.[F5].Resize(ub, 6)
For i = 1 To UBound(col1)
  d = col1(i, 1)
  For j = 1 To 6 
    im = ""
    For k = 1 To ub
      If d <> "" And d = tablo2(k, j) Then _
        im = im & vbLf & col2(k, 1)
    Next
    If im <> "" Then tablo1(i, j) = Mid(im, 2)
  Next
Next
With Feuil1.[B5].Resize(UBound(tablo1), 6)
  .Value = tablo1
  .WrapText = True 'renvoi à la ligne
  .Rows.AutoFit 'ajustement automatique
End With
End Sub

Elle est plus rapide car elle utilise 4 tableaux VBA.

Fichier (2).

A+

 

[pascal21]

Re : reprendre les dates contenues dans une liste pour les mettre dans un tablau

bonjour et merci Job 75, ça semble parfait
je jette un oeil sur le code pour voir comment il fonctionne

 

[job75]

Re : reprendre les dates contenues dans une liste pour les mettre dans un tablau

Bonjour Pascal,

Si l'on veut mettre les immatriculations dans des commentaires :

Sub Immatriculations()
Dim plage1 As Range, plage2 As Range, rc&, i&, d, j As Byte, im$, k&
Set plage1 = Feuil1.Range("B5:G" & Feuil1.[A65536].End(xlUp).Row)
Set plage2 = Feuil2.Range("F5:K" & Feuil2.[E65536].End(xlUp).Row)
rc = plage2.Rows.Count
Application.ScreenUpdating = False
plage1.ClearComments 'RAZ
For i = 1 To plage1.Rows.Count
  d = plage1(i, 0)
  For j = 1 To 6
    im = ""
    For k = 1 To rc
      If d <> "" And d = plage2(k, j) Then _
        im = im & vbLf & plage2(k, 0)
    Next
    If im <> "" Then
      With plage1(i, j).AddComment
        .Text Mid(im, 2)
        .Shape.TextFrame.AutoSize = True
        .Visible = False
      End With
    End If
  Next
Next
End Sub

Fichier (3).

A+

 

[pascal21]

Re : reprendre les dates contenues dans une liste pour les mettre dans un tablau

merci job ça fonctionne parfaitement