Имя диапазона CopyPicture после другой ячейки

Question

Я пытаюсь скопировать ячейки CopyPicture в столбце B и присвоить им значение в столбце 1. У меня есть код, который работает, за исключением того, что он продолжает давать изображениям неправильные имена. Удивительно, что иногда это работает отлично, а иногда нет.

Я попытался объединить процедуру, основываясь на опубликованных примерах команды CopyPicture. Я вставляю это ниже.

Да, я новичок в VBScript. Быть нежным. ; -)

Sub makepic()
    Dim path As String
    path = "C:\BP\BP2020\JPGs\"
    Dim CLen As Integer
    Dim cntr As Integer
    cntr = 1
    Dim rgExp As Range
    Dim CCntr As String
    CString2 = "A1:A6"
    Set rgExp2 = Range(CString2)
    CString = "B1:B6"
    Set rgExp = Range(CString)

    For I = 1 To rgExp.Cells.Count Step 1
      CCntr = rgExp2.Cells(I).Value
      rgExp.Cells.Cells(I).Font.Size = 72
      rgExp.Cells.Cells(I).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
      rgExp.Cells.Cells(I).Font.Size = 14
      ''' Create an empty chart with exact size of range copied
      CLen = Len(rgExp.Cells.Cells(I).Value)
      CWidth = CLen * 85

      With ActiveSheet.ChartObjects.Add(Left:=1600, Top:=rgExp.Top, _
        Width:=CWidth, Height:=50)
        .Name = "ChartVolumeMetricsDevEXPORT"
        .Activate
      End With

      ''' Paste into chart area, export to file, delete chart.
      If CCntr <> "" Then
        ActiveChart.Paste

        Selection.Name = "pastedPic"

        ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export (path + CCntr & ".jpg")
        ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
      End If
      cntr = cntr + 1
   Next
End Sub

Опять же, я ожидаю - например - изображение содержимого ячейки B1 с именем содержимого A1. Я попытался сделать диапазон A1: B4 (например), но это дало мне 8 фотографий. Я наконец решил попробовать сделать 2 диапазона, но это тоже не сработало.