Trombinoscope pour ma classe

Question

Bonjour,

j'ai un tableau avec plusieurs colonne (5) et plusieur ligne(20). pour chaque ligne j'ai des information d'une personne. J'aimerais pouvoir faire un trombinoscope dans une feuille (nommé : "trombinoscope" de mon classeur excel en mettant les informations de la personne dans deux cellule (la photo et dans une cellule en dessous mettre le reste des informations) et de mettre la prochaine personne (ligne suivante) sur la case a coté. De plus il faudrait que chaque personne aille dans le numéro qui lui est concerné (qui seront différencier par le numéro de ligne; numéro1: commence a la ligne 5 et colonne 2; deco : commence a la ligne 2 colonne 2 ; labo : ligne 32 colone 2 ) âpres avoir mis 7 personnes il faudrait changer de ligne
ci dessous le trombinos

Sub CreerTrombinoscope()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim i As Long
    Dim lastRow As Long
    Dim destRow As Long, destCol As Long
    Dim nom As String, prenom As String, age As String, tel As String
    Dim cellPhoto As Range
    Dim pic As Picture

    ' --- Feuilles source et destination ---
    Set wsSrc = ThisWorkbook.Sheets("SST") ' ton tableau source
    Set wsDest = ThisWorkbook.Sheets("Trombinoscope") ' la feuille où afficher

    ' --- Trouver la dernière ligne du tableau source ---
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, 1).End(xlUp).Row

    ' --- Position de départ dans la feuille Trombinoscope ---
    destRow = 5
    destCol = 2

    ' --- Parcours des lignes du tableau ---
    For i = 2 To lastRow   ' ligne 1 = en-têtes
        nom = wsSrc.Cells(i, 1).Value
        prenom = wsSrc.Cells(i, 2).Value
        age = wsSrc.Cells(i, 3).Value
        tel = wsSrc.Cells(i, 4).Value
        Set cellPhoto = wsSrc.Cells(i, 5)

        ' --- Copier la photo si présente ---
        For Each pic In wsSrc.Pictures
            If Not Intersect(pic.TopLeftCell, cellPhoto) Is Nothing Then
                pic.Copy
                wsDest.Paste Destination:=wsDest.Cells(destRow, destCol)
                With wsDest.Pictures(wsDest.Pictures.Count)
                    .Width = 70
                    .Height = 70
                    .Top = wsDest.Cells(destRow, destCol).Top
                    .Left = wsDest.Cells(destRow, destCol).Left
                End With
                Exit For
            End If
        Next pic

        ' --- Écrire les infos sous la photo ---
        wsDest.Cells(destRow + 6, destCol).Value = prenom & " " & nom & vbCrLf & _
                                                   "Âge : " & age & vbCrLf & _
                                                   "Tel : " & tel
        wsDest.Cells(destRow + 6, destCol).WrapText = True
        wsDest.Cells(destRow + 6, destCol).RowHeight = 50
        wsDest.Cells(destRow + 6, destCol).ColumnWidth = 15

        ' --- Passer à la colonne suivante ---
        destCol = destCol + 3

        ' --- Après 5 personnes ? retour à la ligne suivante ---
        If ((i - 1) Mod 6) = 0 Then
            destCol = 1
            destRow = destRow + 12
        End If
    Next i
End Sub

ope souhaité

BsAlv · Accepted Answer

Un essai sans fichier .... Sub CreerTrombinoscope() Dim wsSrc As Worksheet, wsDest As Worksheet Dim i As Long Dim LastRow As Long, FirstRow Dim destRow As Long, destCol As Long Dim nom As String, prenom As String, age As String, tel As String Dim cellPhoto As Range Dim Pic As Picture Dim Dict, Arr, Arr2, ptr, b Set wsSrc = ThisWorkbook.Sheets("SST") ' ton tableau source With wsSrc LastRow = .Cells(Rows.Count, 1).End(xlUp).Row ' --- Trouver la dernière ligne du tableau source --- With .Range("A2:A" & LastRow) FirstRow = .Row Arr = .Resize(, 4).Value2 'matrice qui lit le contenu de votre plage End With Set Dict = CreateObject("scripting.dictionary") 'créer un dictionaire pour mémoriser les adresses des pictures For Each Pic In .Pictures 'boucler tous les pictures Dict(Pic.TopLeftCell.Address) = Pic.Index 'le n° du picture comme item, son adresse comme key Next MsgBox Join(Dict.keys, vbLf), vbInformation, "cellules avec pictures" End With With ThisWorkbook.Sheets("Trombinoscope") ptr = 0 'compteur des données For i = 5 To 1000 Step 12 'ligne en intervalle de 12 For j = 2 To 14 Step 3 'colonne en intervalle de 3 (5 en total, càd 2,5,8,11 et 14) ptr = ptr + 1 'donnée suivante If ptr &gt; UBound(Arr) Then Exit For 'si on a traité toutes les données = EXIT s = .Cells(FirstRow - 1 + ptr, "E").Address 'adresse qui correspond avec la cellule de SST pour sa photo b = Dict.exists(s) 'y-a-t-il une photo dans cette cellule de SST ? If b Then 'oui ! .Cells(i, j).Value = "" 'contenu vide de la cellule Set Pic = wsSrc.Pictures(Dict(s)) 'la photo qui correspond avec ces données Pic.Copy 'copier photo .Paste .Range("A1") 'coller dans "trombo..." DoEvents: DoEvents: DoEvents: DoEvents: DoEvents 'freiner,patienter un peu DoEvents: DoEvents: DoEvents: DoEvents: DoEvents 'freiner,patienter un peu With .Pictures(.Pictures.Count) 'adapter la dernière picture .Width = 70 .Height = 70 .Top = .Cells(i, j).Top .Left = .Cells(i, j).Left End With Else .Cells(i, j).Value = "photo inconnu" 'photo inconnu End If With Cells(i + 1, j) 'la cellule juste en dessous ce photo .Value = Arr(ptr, 1) & " " & Arr(ptr, 2) & vbLf & "Âge : " & Arr(ptr, 3) & vbCrLf & "Tel : " & Arr(ptr, 4) .WrapText = True .RowHeight = 50 .ColumnWidth = 15 End With Next If ptr &gt; UBound(Arr) Then Exit For Next End With End Sub...

saboh12617 · Answer

Pouvez-vous : Préciser ce qui ne fonctionne pas dans votre code actuel ? Fournir le fichier correspondant (anonymisé) afin que l'on vous donne une réponse adaptée. Merci...