Microsoft 365 Récupérer les informations dans différentes feuilles dans des lignes différentes

[mxh]

Bonjour à tous,

je souhaite récupérer les informations d'un meme nom dans plusieurs feuilles mais ne se trouvant pas à chaque fois sur le meme numéro de ligne.

Pouvez vous m'aider ?

Merci d'avance !

cordialement !

Mxh

 

[mxh]

Merci beaucoup job75 !!

Le programme marche bien, j'aurai encore une question, serait il possible de faire la meme chose en fonction d'un autre fichier excel ?

Merci de votre aide !!

 

[job75]

Bonjour mxh,

Téléchargez les 2 fichiers joints dans le même dossier (le bureau) et ouvrez le fichier .xlsm.

La macro Workbook_Open dans ThisWorkbook déclenche ce code :

Private Sub Workbook_Open()
Application.OnTime 1, ThisWorkbook.CodeName & ".MAJ" 'lance la macro
End Sub

Sub MAJ()
Dim chemin$, fichier$, F As Worksheet, ncol%, coldeb%, lig&, d As Object, wb As Workbook, w As Worksheet, c As Range, x$, n&, col%
chemin = ThisWorkbook.Path & "\"
fichier = "Source.xlsx"
If Dir(chemin & fichier) = "" Then MsgBox "Fichier '" & fichier & "' introuvable !", 48: Exit Sub
Set F = Feuil1 'CodeName de la feuille de destination
ncol = 7
coldeb = 2
lig = 2
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
F.Rows(lig + 1 & ":" & F.Rows.Count).Delete 'RAZ
On Error Resume Next
Workbooks(fichier).Close False 'ferme le fichier s'il est ouvert
On Error GoTo 0
Set wb = Workbooks.Open(chemin & fichier) 'ouverture du fichier source
For Each w In wb.Sheets(Array("Feuil1", "Feuil2", "Feuil3", "Feuil4", "Feuil5", "Feuil6")) 'nom des feuilles à adapter
    For Each c In w.UsedRange.Columns(1).Cells
        x = LCase(c)
        If x <> "" Then
            If Not d.exists(x) Then
                lig = lig + 1
                d(x) = lig 'mémorise le n° de ligne
                c.Copy F.Cells(lig, 1) 'copie le nom
            End If
            n = d(x) 'récupère le n° de ligne
            c(1, 2).Resize(, ncol).Copy F.Cells(n, coldeb) 'copier-coller
            For col = coldeb To coldeb + ncol - 1
                With F.Cells(n, col)
                    If .Interior.ColorIndex = 3 Then 'si rouge
                        .Value = "AT"
                        .Font.ColorIndex = 2 'police blache
                    ElseIf .Interior.ColorIndex = 15 Then 'si gris
                        .Value = "NT"
                        .Font.ColorIndex = 2 'police blanche
                        .Interior.ColorIndex = 1 'fond noir
                        .Borders(xlDiagonalUp).LineStyle = xlNone
                        .Borders(xlDiagonalDown).LineStyle = xlNone
                    End If
                End With
            Next col
        End If
    Next c
    coldeb = coldeb + ncol 'décalage vers la droite
Next w
wb.Close False 'ferme le fichier source
End Sub