这能给予你的需要吗

Sub list_charts_in_top_left_to_bottom_right()
    
    Dim ws As Worksheet, outputsh As Worksheet, last_cell As Range, oChartObj As Object
    
    Set ws = ThisWorkbook.Sheets("SheetWithChartsOnIt")
    Set outputsh = ThisWorkbook.Sheets("SheetToWriteTo")
    
    outputsh.Range("A:A").ClearContents
    
    outputsh.Range("A1") = "Output:"
    
    If ws.ChartObjects.Count = 0 Then
        outputsh.Range("A2") = "No charts found"
        Exit Sub
    End If
    
    Debug.Print "Charts found: " & ws.ChartObjects.Count
    
    Set last_cell = ws.Range("A1")
    
    'find bounds of range by expanding last_cell with each chart
    For Each oChartObj In ws.ChartObjects
        With oChartObj

            If .TopLeftCell.Row > last_cell.Row Then Set last_cell = ws.Cells(.TopLeftCell.Row, last_cell.Column)
            If .TopLeftCell.Column > last_cell.Column Then Set last_cell = ws.Cells(last_cell.Row, .TopLeftCell.Column)
        End With
    Next
    
    Debug.Print "Bounds of range: $A$1:" & last_cell.Address

    Dim area_to_examine As Range

    For col = 5 To last_cell.Column Step 21 'start with column 5 (E) and then jump 21 columns at a time
    
    Set area_to_examine = Range(Columns(col), Columns(col + 17))
    
    Debug.Print "Examining: " & area_to_examine.Address
    
        For Each rw In Intersect(area_to_examine, ws.Range("A1", last_cell.Address).Rows)
            For Each cl In rw.Cells
                For Each oChartObj In ws.ChartObjects
                    With oChartObj
                        If .TopLeftCell.Row = cl.Row And .TopLeftCell.Column = cl.Column Then
                        outputsh.Cells(outputsh.Rows.Count, "A").End(xlUp).Offset(1) = .Name
                        Debug.Print .Name
                        End If
                    End With
                Next
            Next
        Next
    Next
End Sub

这是一种替代方法，它仍然没有使用排序算法，而是使用了一种变通方法（确实浪费了一点时间，但是），这比扫描工作表中的每个单元格要快得多：

Sub list_charts_in_top_left_to_bottom_right_v2()
    
    Dim ws As Worksheet, outputsh As Worksheet, chartCount As Long, x As Long, y As Long, maxZ As Long
    
    Set ws = ThisWorkbook.Sheets("SheetWithChartsOnIt")
    Set outputsh = ThisWorkbook.Sheets("SheetToWriteTo")
    
    outputsh.Range("A:A").ClearContents
    
    outputsh.Range("A1").Value = "Chart"
    chartCount = ws.ChartObjects.Count
    
    ReDim arrChartlist(chartCount, 1)
    
    If chartCount = 0 Then
        outputsh.Range("A2") = "No charts found"
        Exit Sub
    End If
           
    maxZ = 0
    
    For x = 0 To chartCount - 1
        With ws.ChartObjects(x + 1)
            arrChartlist(x, 0) = .Name
            arrChartlist(x, 1) = (((.TopLeftCell.Column - 2) \ 19) * chartCount * chartCount) + (.TopLeftCell.Column * chartCount) + .TopLeftCell.Row
            If maxZ < arrChartlist(x, 1) Then maxZ = arrChartlist(x, 1)
        End With
    Next

    For x = 0 To maxZ
        For y = 0 To chartCount - 1
            If x = arrChartlist(y, 1) Then
                outputsh.Cells(outputsh.Rows.Count, "A").End(xlUp).Offset(1).Value = arrChartlist(y, 0)
            End If
        Next
    Next
      
End Sub