Sub qq()
    Dim ws As Worksheet, Chrt As ChartObject, i&, arr2, k&, n&
    Dim WrdApp As Object, WrdDoc As Object
    Set WrdApp = CreateObject("Word.Application")
    Set WrdDoc = WrdApp.Documents.Add
    ReDim arr2(1 To 1)
    For Each ws In ThisWorkbook.Worksheets
        Dim coll As New Collection
        For Each Chrt In ws.ChartObjects
            Dim arr(1 To 3)
            arr(1) = Chrt.Top
            arr(2) = Chrt.Index
            arr(3) = ws.Name
            For i = 1 To coll.Count
                If arr(1) < coll.Item(i)(1) Then Exit For
            Next
            If i > coll.Count Then coll.Add arr Else coll.Add arr, Before:=i
        Next
        If coll.Count > 0 Then
            If n < coll.Count Then n = coll.Count
            k = k + 1
            ReDim Preserve arr2(1 To k)
            Set arr2(k) = coll
        End If
        Set coll = Nothing
    Next
 
        For i = 1 To n
            For k = 1 To UBound(arr2)
                Worksheets(arr2(k)(i)(3)).ChartObjects(arr2(k)(i)(2)).CopyPicture
                WrdApp.Selection.Paste
            Next
        Next
WrdApp.Visible = True
End Sub