Excel 使用For循环从其他图纸返回命名图表

我尝试使用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

---

非常感谢

以下内容如何，它不仅会循环浏览您的工作表，而且还会在检查名称是否匹配之前检查并循环浏览每个工作表中的图表，如果匹配，则将图表粘贴到Sheet1 A列的下一行：

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

---

以下内容如何？它不仅会在工作表中循环，还会在检查名称是否匹配之前检查并循环每个工作表中的图表，如果匹配，则将图表粘贴到Sheet1 A列的下一行：

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

---

a） 避免选择/激活：，b）除非您有多个可以粘贴的图表，否则您很可能希望在找到/粘贴图表后退出子例程，c）此循环将是合适的，因为您确实需要逐页查找形状您说“函数”，但没有调用函数，因此您的意思不清楚。此外，您在循环之前设置了aCharName，并且不再设置它，因此您将只复制/粘贴该图表。您的引用单元格是否包含您不共享的公式？a）避免选择/激活：，b）除非您有多个可以粘贴的图表，否则您很可能希望在找到/粘贴图表后退出子例程，并且c）此循环是合适的，因为您确实需要逐页查找形状您说“函数”但是没有调用函数，所以您的意思不清楚。此外，您在循环之前设置了aCharName，并且不再设置它，因此您将只复制/粘贴该图表。您的引用单元格是否包含您不共享的公式？当我使用此代码时，程序将冻结。事实上，当我试图摆脱一些。选择的程序也冻结。我应该注意到，我正在使用数据验证，因此这是一个工作表更改子项@a.s.我现在已经更新了我的答案，我相信这应该可以按预期工作，请尝试并让我知道是否有任何问题。谢谢：）谢谢，但这一次我在A2得到了30多个texbox，我想问题在循环中。它基本上复制和粘贴图表的次数与文档中的图纸相同。当我使用此代码时，程序冻结。事实上，当我试图摆脱一些。选择的程序也冻结。我应该注意到，我正在使用数据验证，因此这是一个工作表更改子项@a.s.我现在已经更新了我的答案，我相信这应该可以按预期工作，请尝试并让我知道是否有任何问题。谢谢：）谢谢，但这一次我在A2得到了30多个texbox，我想问题在循环中。它基本上复制和粘贴图表的次数与文档中的图纸数量相同