Как лучше всего вставить эти диаграммы в виде отдельных PNG в определенном порядке в 4 столбца?

Question

У меня есть большая таблица Excel с диаграммами, которые загружаются медленно, когда я прокручиваю их вниз, чтобы просмотреть их.Я хочу вставить их как изображения меньшего размера (PNG или JPEG), потому что я думаю, что это предотвратит отставание.Мне нужно, чтобы это было организовано как сетка из 4 столбцов.Сами диаграммы уже в правильном порядке.

Я попытался использовать .Shapes.SelectAll, а затем скопировать его на новый лист, используя ActiveSheet.PasteSpecial Format: = "Picture (PNG)".Это работает для небольшого количества графиков.Проблема в том, что он вставляет их в одно большое изображение.Когда у меня большое количество диаграмм (~ 4000 диаграмм), файл никогда не загрузится.

Итак, я попытался перебрать объекты диаграммы и вставить их по одному на новый лист.Они, очевидно, в конечном итоге укладываются друг на друга.Поэтому я попытался расположить их, как только они были вставлены, но они вышли из строя.Я думаю, потому что я выбираю их по одному столбцу за раз.

Dim CurrentSheet As Worksheet
Dim cht As ChartObject


Set CurrentSheet = ActiveSheet
  For Each cht In sht.ChartObjects
    cht.Activate
    ActiveChart.ChartArea.Select
    Selection.Copy
    Sheets("CoverSheet").Select
    ActiveSheet.PasteSpecial Format:="Picture (PNG)"

  Next cht

Затем я просматривал их, но они вышли из строя ..

Dim shp As Shape
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Dim dWidth As Double
Dim dSPACE As Variant
Dim lRowCnt As Variant
Dim dStart As Double
Dim dMaxHeight As Double

 lRowCnt = 4
 dSPACE = 1
 lCnt = 1



  ActiveSheet.Shapes.SelectAll

  'Loop through selected shapes (charts, slicers, timelines, etc.)
   For Each shp In Selection.ShapeRange
    With shp
      'If first shape then store left position
      If lCnt = 1 Then
        dStart = .Left
      Else
        If lCnt Mod lRowCnt = 1 Or lRowCnt = 1 Then
          'New row, move shape down
          .Top = dTop + dMaxHeight + dSPACE
          .Left = dStart
          dMaxHeight = .Height
        Else
          'Same row, move shape right
          .Top = dTop
          .Left = dLeft + dWidth + dSPACE
        End If

      End If

      'Store properties of shape for use in moving next shape in the collection.
      dTop = .Top
      dLeft = .Left
      dHeight = .Height
      dWidth = .Width
      dMaxHeight = WorksheetFunction.Max(dMaxHeight, .Height)
    End With

    'Add to shape counter
    lCnt = lCnt + 1
  Next shp

Мне нужно, чтобы они были размещены в виде сетки из 4 столбцов с таким количеством строк, какЕсть графики.Это будет тот же порядок, что и в оригинальных графиках.Я бы хотел один пробел между каждым столбцом и строкой.