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
Необходимо перед вставкой в Word уменьшить размер рисунков(графиков), так как Word не тянет. Возможно, файл получается более 500 мегабайт, так как картинок (графиков) порядка 1200.