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

pascal21

XLDnaute Barbatruc
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
 

Pièces jointes

  • fichier véhicules.xls
    16.5 KB · Affichages: 53
  • fichier véhicules.xls
    16.5 KB · Affichages: 60
  • fichier véhicules.xls
    16.5 KB · Affichages: 59

job75

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

Bonjour pascal21,

Voir le fichier joint avec cette macro :

Code:
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+
 

Pièces jointes

  • fichier véhicules(1).xls
    37.5 KB · Affichages: 38
Dernière édition:

job75

XLDnaute Barbatruc
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 :

Code:
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+
 

Pièces jointes

  • fichier véhicules(2).xls
    38.5 KB · Affichages: 51
Dernière édition:

job75

XLDnaute Barbatruc
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 :

Code:
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+
 

Pièces jointes

  • fichier véhicules(3).xls
    39.5 KB · Affichages: 46

Discussions similaires

Statistiques des forums

Discussions
312 927
Messages
2 093 681
Membres
105 782
dernier inscrit
obelix76