Is there a way to list chart numbers based on position in the spreadsheet? (Not in sorted order?)-CodePudding

The following macro lists all the chart numbers of by worksheet but it order them and this is not how the charts appear in the sheet.

Sub ListChartNames()
Dim Cht As ChartObject
Dim i As Integer
i = 1
For Each Cht In ActiveSheet.ChartObjects
Cells(i, 1) = Cht.Chart.Name
i = i   1
Next Cht
End Sub

For example, I have a chart in E6:L17 (let's call this one Chart 1) and another in N6:U17 (let's call this one Chart 11). Then, I move down to two charts in E19:L30 (let's call this one Chart 400) and another in N19:U30 (let's call this one Chart 2). Then, I move down to two charts in E32:L43 (let's call this one Chart 3) and another in N32:U43 (let's call this one Chart 12) Then, I move down to only 1 chart in E45:L56 (let's call this one Chart 13) Then, I back to two charts in E58:L69 and another in N58:U69 (let's call these Chart 15 and Chart 16) and so on.....

The above charts are all in columns E through U. But then there is another set in columns Y through AO in same patter and again in AS through BI, etc.

I have like 500 charts and I'd like a macro to list them starting in the first set of columns (E through L) but list them from top to bottom, let to right.

So, the results based on the above would be for columns F through U Chart 1 Chart 11 Chart 400 Chart 2 Chart 3 Chart 12 Chart 13 Chart 15 Chart 16

The macro above lists the charts in a sorted order which is not what I need.

This also doesn't answer the question: Select chart object based on position in sheet (VBA)

CodePudding user response：

Does this give you what you need?

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

CodePudding user response：

This is an alternative method. It's still not using a sort algo, but uses a workaround which (does waste a little time but) should be massively quicker than scanning every cell in the sheet:

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