Microsoft 365 Extraire texte de toutes les zones de texte

Sub Worksheet_Activate()
Dim Ligne%, L%, F, strNomForme, strAdresseCellule
[A2:D1000].ClearContents
Ligne = 2: Set F = Sheets("Orga complete")
For Each img In F.Shapes
    strNomForme = img.Name
    strAdresseCellule = CStr(F.Shapes(strNomForme).TopLeftCell.Address)
    L = Split(strAdresseCellule, "$")(2)
    Cells(Ligne, "A") = F.Cells(L - 2, "B") & F.Cells(L - 1, "B") & F.Cells(L, "B") & F.Cells(L + 1, "B") & F.Cells(L + 2, "B")
    Cells(Ligne, "B") = img.TextFrame2.TextRange.Text
    ' Cells(Ligne, "C") = strAdresseCellule ' A valider si on veut l'adresse de la cellule.
    ' Cells(Ligne, "D") = strNomForme       ' A valider si on veut le nom du shape.
    Ligne = Ligne + 1
Next
End Sub

Cells(Ligne, "B") = img.TextFrame.Characters.Text

Sub Worksheet_Activate()
Dim Ligne%, L%, F, strNomForme, strAdresseCellule, img As Object
[A2:D1000].ClearContents
Ligne = 2: Set F = Sheets("Orga complete")
For Each img In F.DrawingObjects
    strNomForme = img.Name
    strAdresseCellule = CStr(F.Shapes(strNomForme).TopLeftCell.Address)
    L = Split(strAdresseCellule, "$")(2)
    Cells(Ligne, "A") = F.Cells(L - 2, "B") & F.Cells(L - 1, "B") & F.Cells(L, "B") & F.Cells(L + 1, "B") & F.Cells(L + 2, "B")
    On Error Resume Next
    Cells(Ligne, "B") = img.Text
    Ligne = Ligne + 1
Next
End Sub