Macro to list out chart names into a sheet column

[BuJay]

I thought I asked this question here but I can't find it....

I have a macro that examines charts in columns D through T, and then W through AM, and this continues until columns JJ through JZ. There are 15 groups of charts.

The code below lists the charts from upper left to lower right in columns D throgh T....then it lists out the charts from upper left to lower right in columns W through AM, and so on....

The code works....but it is EXTREMELY slow....does anyone see anything here that could be adjusted to speed it up?

Thanks!

Option Explicit

Sub list_charts()
   
    Dim ws As Worksheet
    Dim outputsh As Worksheet
    Dim last_cell As Range
    Dim oChartObj As Object
    Dim area_to_examine As Range
    Dim col As Long
    Dim rw As Object
    Dim cl As Object
   
    Set ws = ThisWorkbook.Sheets("charts")
    Set outputsh = ThisWorkbook.Sheets("charts")
   
    Sheets("charts").Activate
    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")
   
    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


    'start with column 4 (D) and then jump 19 columns at a time
    For col = 4 To last_cell.Column Step 19

    Set area_to_examine = Range(Columns(col), Columns(col + 16))

    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

 

[DanteAmor]

Hi @BuJay

Try this:

Sub list_charts()
  Dim ws As Worksheet, oChartObj As Object
  Dim lCell As Range, col As Long
  
  Set ws = ThisWorkbook.Sheets("charts")
  ws.Range("A:A").ClearContents
  ws.Range("A1") = "Output:"
  Set lCell = ws.Range("A1")    'last cell
  
  For Each oChartObj In ws.ChartObjects
    With oChartObj
      col = .TopLeftCell.Column
      If .TopLeftCell.Row >= lCell.Row And col >= lCell.Column And col Mod 19 <> 2 And col Mod 19 <> 3 Then
        ws.Cells(ws.Rows.Count, "A").End(3)(2) = .Name
      End If
    End With
  Next
  If col = 0 Then ws.Range("A2") = "No charts found"
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[Micron]

Pardon me for not reading all of that because I'm not sure what you are trying to achieve. If you just want a list of charts, why not simply iterate over the Charts collection for chart sheets or ChartObjects collection for charts on sheets? Or both - instead of looping over a range of cells which may not contain the correct chart name value anyway?

Late to the party, but might as well ask anyway since I had this composed.

 

[BuJay]

Hi @BuJay

Try this:

Sub list_charts()
  Dim ws As Worksheet, oChartObj As Object
  Dim lCell As Range, col As Long
 
  Set ws = ThisWorkbook.Sheets("charts")
  ws.Range("A:A").ClearContents
  ws.Range("A1") = "Output:"
  Set lCell = ws.Range("A1")    'last cell
 
  For Each oChartObj In ws.ChartObjects
    With oChartObj
      col = .TopLeftCell.Column
      If .TopLeftCell.Row >= lCell.Row And col >= lCell.Column And col Mod 19 <> 2 And col Mod 19 <> 3 Then
        ws.Cells(ws.Rows.Count, "A").End(3)(2) = .Name
      End If
    End With
  Next
  If col = 0 Then ws.Range("A2") = "No charts found"
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

That was sooooo much faster....but it doesn't generate the desired results.....please see the below. The desired results should:

....starting out in columns D:T and then from top to bottom, left to right, generate chart names....(see image below)

So, results should be Chart 3, Chart 5, Chart 8, Chart 7, Chart 9, Chart 1, .....till all 11 charts in columns D:F are listed.

Then, move to columns W:AM where the list continues with these charts...., Chart 2, Chart 4, Chart 14, Chart 15, Chart 16, Chart 17, .... until the 11 all 11 charts in column W:AM are listed, and then move to columns AP:BF,.....this patter continues until columns JJ:JZ (so 15 sets of 11 charts....)

The results from DanteAmor's suggestion show Chart 3, Chart 5, Chart 7, Chart 8 - where what is needed is Chart 3, Chart 5, Chart 8, Chart 7 as one example.

An alternative solution would be to reset all chart counters - maybe even start them at 1001, so rename from Chart 1001 through Chart 1165 - but would still need the macro to name them in the order described above, so not sure if it helps or not....

 

[DanteAmor]

Hi @BuJay

Thanks for the explanation and for the image, now it is clearer for me.

Please try the following macro to see if it works for you. Specifically, the "System.Collections.ArrayList" object, if it doesn't work then we look for another alternative to order the data.
Can you confirm that in rows 1 and 2 you have data? that way we can find the last column with data from the sheet.
If you don't have data, then we can also look for another alternative.

Sub list_charts()
  Dim ws As Worksheet
  Dim oChartObj As Object, coll As Object
  Dim i As Long, j As Long, lc As Long
  Dim rngcol As Range
  Dim sCua As String, sCol As String, sRow As String
  Dim itm As Variant
 
  Set coll = CreateObject("System.Collections.ArrayList")
 
  Set ws = ThisWorkbook.Sheets("charts")
  ws.Range("A2:A" & Rows.Count).ClearContents
 
  lc = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
 
  For j = 4 To lc Step 19
    Set rngcol = ws.Cells(2, j).Resize(1, 17).EntireColumn
    sCua = Format(rngcol.Cells(1).Column, "00000|")
    For Each oChartObj In ws.ChartObjects
      With oChartObj
        If Not Intersect(.TopLeftCell, rngcol) Is Nothing Then
          sRow = Format(.TopLeftCell.Row, "00000|")
          sCol = Format(.TopLeftCell.Column, "00000|")
          coll.Add sCua & sRow & sCol & .Name
        End If
      End With
    Next
  Next
 
  coll.Sort
  For Each itm In coll
    Range("A" & Rows.Count).End(3)(2).Value = Split(itm, "|")(3)
  Next
End Sub

I did a test with 1300 charts, they were processed in 5 seconds.

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[DanteAmor]

Hi @BuJay

This option is faster, with 1300 charts the response is immediate.

Sub list_charts()
  Dim ws As Worksheet
  Dim oChartObj As Object, coll As Object, dict As Object
  Dim i As Long, j As Long, lc As Long, n As Long, m As Long
  Dim sCua As String
  Dim itm As Variant
 
  Application.ScreenUpdating = False
  Set coll = CreateObject("System.Collections.ArrayList")
  Set dict = CreateObject("Scripting.Dictionary")
  Set ws = ThisWorkbook.Sheets("charts")
  ws.Range("A2:A" & Rows.Count).ClearContents
 
  lc = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
  n = 1
  For j = 4 To lc
    m = (j - 3) Mod 19
    Select Case m
      Case 1 To 17
        i = i + 1
        dict(j) = Format(n, "00000|")
      Case 18
        i = 0
        n = n + 1
    End Select
  Next
 
  For Each oChartObj In ws.ChartObjects
    With oChartObj
      j = .TopLeftCell.Column
      m = (j - 3) Mod 19
      If m >= 1 And m <= 17 Then
        sCua = dict(.TopLeftCell.Column)
        coll.Add sCua & Format(.TopLeftCell.Row, "00000|") & Format(j, "00000|") & .Name
      End If
    End With
  Next

  coll.Sort
  ReDim b(1 To coll.Count, 1 To 1)
  i = 0
  For Each itm In coll
    i = i + 1
    b(i, 1) = Split(itm, "|")(3)
  Next
  ws.Range("A2").Resize(UBound(b)).Value = b
  Application.ScreenUpdating = True
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​

 

[BuJay]

Hi @BuJay

This option is faster, with 1300 charts the response is immediate.

Sub list_charts()
  Dim ws As Worksheet
  Dim oChartObj As Object, coll As Object, dict As Object
  Dim i As Long, j As Long, lc As Long, n As Long, m As Long
  Dim sCua As String
  Dim itm As Variant
 
  Application.ScreenUpdating = False
  Set coll = CreateObject("System.Collections.ArrayList")
  Set dict = CreateObject("Scripting.Dictionary")
  Set ws = ThisWorkbook.Sheets("charts")
  ws.Range("A2:A" & Rows.Count).ClearContents
 
  lc = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
  n = 1
  For j = 4 To lc
    m = (j - 3) Mod 19
    Select Case m
      Case 1 To 17
        i = i + 1
        dict(j) = Format(n, "00000|")
      Case 18
        i = 0
        n = n + 1
    End Select
  Next
 
  For Each oChartObj In ws.ChartObjects
    With oChartObj
      j = .TopLeftCell.Column
      m = (j - 3) Mod 19
      If m >= 1 And m <= 17 Then
        sCua = dict(.TopLeftCell.Column)
        coll.Add sCua & Format(.TopLeftCell.Row, "00000|") & Format(j, "00000|") & .Name
      End If
    End With
  Next

  coll.Sort
  ReDim b(1 To coll.Count, 1 To 1)
  i = 0
  For Each itm In coll
    i = i + 1
    b(i, 1) = Split(itm, "|")(3)
  Next
  ws.Range("A2").Resize(UBound(b)).Value = b
  Application.ScreenUpdating = True
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​

Automation error

Set coll = CreateObject("System.Collections.ArrayList")

I’ll have to dig around on my end to see what that means…

 

[BuJay]

Hi @BuJay

Thanks for the explanation and for the image, now it is clearer for me.

Please try the following macro to see if it works for you. Specifically, the "System.Collections.ArrayList" object, if it doesn't work then we look for another alternative to order the data.
Can you confirm that in rows 1 and 2 you have data? that way we can find the last column with data from the sheet.
If you don't have data, then we can also look for another alternative.

Sub list_charts()
  Dim ws As Worksheet
  Dim oChartObj As Object, coll As Object
  Dim i As Long, j As Long, lc As Long
  Dim rngcol As Range
  Dim sCua As String, sCol As String, sRow As String
  Dim itm As Variant
 
  Set coll = CreateObject("System.Collections.ArrayList")
 
  Set ws = ThisWorkbook.Sheets("charts")
  ws.Range("A2:A" & Rows.Count).ClearContents
 
  lc = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
 
  For j = 4 To lc Step 19
    Set rngcol = ws.Cells(2, j).Resize(1, 17).EntireColumn
    sCua = Format(rngcol.Cells(1).Column, "00000|")
    For Each oChartObj In ws.ChartObjects
      With oChartObj
        If Not Intersect(.TopLeftCell, rngcol) Is Nothing Then
          sRow = Format(.TopLeftCell.Row, "00000|")
          sCol = Format(.TopLeftCell.Column, "00000|")
          coll.Add sCua & sRow & sCol & .Name
        End If
      End With
    Next
  Next
 
  coll.Sort
  For Each itm In coll
    Range("A" & Rows.Count).End(3)(2).Value = Split(itm, "|")(3)
  Next
End Sub

I did a test with 1300 charts, they were processed in 5 seconds.

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

Looks like the "System.Collections.ArrayList" is throwing an error. I can put data into columns A and B (headers....) just to have something there if it helps.... main need is to create the list so I can use that list to order the charts that are moved to powerpoint with another macro....

In other words, the endgame here is to move them from Excel to PowerPoint in a specific order....

 

[DanteAmor]

Automation error
Set coll = CreateObject("System.Collections.ArrayList")

Don't worry, as I told you, it can be fixed.

You did not confirm the use of rows 1 or 2 with data.

Try this version to sort the data. For 1400 charts the process is 3 seconds. How many charts do you have on the sheet?

Copy all of the following code including the first line and the procedure at the end.

Dim collsort As New Collection        'At the start of all code

Sub list_charts_v4()
  Dim ws As Worksheet
  Dim oChartObj As Object, dict As Object
  Dim i As Long, j As Long, n As Long
  Dim sCua As String, itm As Variant
  Dim coll As New Collection
 
  Application.ScreenUpdating = False
  Set dict = CreateObject("Scripting.Dictionary")
  Set ws = ThisWorkbook.Sheets("charts")
  ws.Range("A2:A" & Rows.Count).ClearContents
 
  n = 1
  For j = 2 To ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
    i = i + 1
    If i = 20 Then n = n + 1: i = 1
    dict(j) = Format(n, "00000|")
  Next
 
  For Each oChartObj In ws.ChartObjects
    With oChartObj
      sCua = dict(.TopLeftCell.Column)
      coll.Add sCua & Format(.TopLeftCell.Row, "00000|") & Format(.TopLeftCell.Column, "00000|") & .Name
    End With
  Next

  'Sort
  For Each itm In coll
    Call sort_arr(itm)
  Next
 
  ReDim b(1 To collsort.Count, 1 To 1)
  i = 0
  For Each itm In collsort
    i = i + 1
    b(i, 1) = Split(itm, "|")(3)
  Next

  ws.Range("A2").Resize(UBound(b)).Value = b
  Application.ScreenUpdating = True
End Sub

Sub sort_arr(itm)
  Dim i As Long
  For i = 1 To collsort.Count
    Select Case StrComp(collsort(i), itm, vbTextCompare)
      Case 0: Exit Sub                            'exits
      Case 1: collsort.Add itm, Before:=i: Exit Sub  'add before
    End Select
  Next
  collsort.Add itm 'add at end
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​

 

[DanteAmor]

I can put data into columns A and B (headers....) just to have something there if it helps....

In your image I see that you have data in rows 1 and 2. I just want you to confirm if you have data in those rows, the macro needs it to calculate the last column with data.