Использование цикла For для возврата именованных диаграмм с других листов

Question

Я пытаюсь использовать цикл For для копирования / вставки именованных диаграмм с тем же именем, что и у базовой ячейки, и функция ниже возвращает правильную диаграмму, но просто копирует / вставляет диаграмму в вопросе 36 раз (числорабочие листы в моем документе).Я использую неправильную функцию для начала?

Dim aChar As ChartObject 'these lines define the name of the chart
Dim aFlag As Boolean
Dim aCharName As String
On Error Resume Next
Application.ScreenUpdating = False
aCharName = (Sheets("Sheet1").Range("A1"))
aFlag = False
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets 'The For Loop: I think this is where the problem is

If aChar.Name = aCharName Then

ws.ChartObjects(Sheets("Sheet1").Range("A1")).Activate
ActiveChart.ChartArea.Copy 'from now on the simple copy/paste 
Sheets("Sheet1").Select
Range("A2").Select
ActiveSheet.Pictures.Paste

End If

Next

большое спасибо

Answer 1

Как насчет следующего, он не только будет циклически проходить по вашим рабочим листам, но затем проверяет и циклически просматривает ваши диаграммы в каждом рабочем листе, прежде чем проверять, совпадает ли имя, и, если это так, вставляет диаграмму в следующую доступную строку в столбце AЛист1:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim aFlag As Boolean: aFlag = False
Dim aCharName As String: aCharName = Sheets("Sheet1").Range("A1").Value
Dim i As Long
Dim ws As Worksheet
'On Error Resume Next
Application.ScreenUpdating = False
    For Each ws In ThisWorkbook.Worksheets 'The For Loop: I think this is where the problem is
        If ws.ChartObjects.Count > 0 Then 'check if there are any charts in worksheet
            For i = 1 To ws.ChartObjects.Count 'loop through charts
                If ws.ChartObjects.Name = aCharName Then
                    ws.ChartObjects(aCharName).ChartArea.Copy 'from now on the simple copy/paste
                    LastRow = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row ' get the last row
                    Sheets("Sheet1").Select
                    Sheets("Sheet1").Range("A" & LastRow).Select
                    ActiveSheet.Pictures.Paste 'paste in the new last row
                    'probably best to use Offset to paste for the next iteration of the For Loop
                End If
            Next i
        End If
    Next
Application.ScreenUpdating = True
End Sub