[Solved] Excel VBA error: “cannot complete task with available resources”

by


I understood your goal as: single chart per sheet that exists in the All Data list

Your code was creating (as @vba4all suggested) too many charts. I added:

  1. sheetsHandled as Collection to hold the list of sheets that
    already got their charts.
  2. sheetName to hold the name of the sheet used many times in code.
  3. Function StringExistsInCollection that looks for the sheetName
    in sheetsHandled.

So here is the fixed code:

Sub ForecastsCharts()

    Dim ChtOb As ChartObject
    Dim lw As Long
    Dim rng As Range
    Dim RngToCover As Range
    Dim sShapeName As String
    Dim shtrng As Range
    Dim i As Long
    Dim RowIndex As Long
    Dim ad As Worksheet
    Dim col As Long
    Dim DataRow As Long
    Dim rw As Long
    Dim allDataSheet As Worksheet

    Dim sheetsHandled As New Collection 'Collection for chart references
    Dim sheetName As String ' Name of the sheet being handled (used many times)

    Set allDataSheet = Sheets("All Data")
    Application.ScreenUpdating = False

    DataRow = 8

    Do Until allDataSheet.Cells(DataRow, 2).Value = "" ' Loop through All Data rows

    sheetName = allDataSheet.Cells(DataRow, 2).Value 'Name is memorised here

    If Not StringExistsInCollection(sheetsHandled, sheetName) Then

        sheetsHandled.Add sheetName 'Remember we handled the sheet

        With Sheets(sheetName) ' Output will go to the applicable Portfolio sheet found in column B

        Set rng = .Range("B8").CurrentRegion

        'If Application.CountIf(rng, "<>") = rng.Columns.Count Then   ' All data points required

        If Application.CountIf(rng, "<>") > 0 Then    ' At least one data point

            With .Shapes.AddChart(Left:=48, Width:=468, Top:=300, Height:=300).Chart
                .PlotBy = xlRows
                .ChartType = xlColumnClustered
                For RowIndex = 2 To rng.Rows.Count
                    With .SeriesCollection.NewSeries
                        'This is the series name
                        .Name = "='" & sheetName & "'!" & rng.Cells(RowIndex, 1).Address(, , xlR1C1)
                        .Values = "='" & sheetName & "'!" & rng.Rows(RowIndex).Cells(1, 2).Resize(1, rng.Columns.Count - 1).Address(, , xlR1C1)
                        .XValues = "='" & sheetName & "'!" & rng.Rows(1).Cells(1, 2).Resize(1, rng.Columns.Count - 1).Address(, , xlR1C1)
                        .ApplyDataLabels AutoText:=True, LegendKey:=False, _
                            HasLeaderLines:=True, ShowSeriesName:=False, _
                            ShowCategoryName:=False, ShowValue:=True, _
                            ShowPercentage:=True, ShowBubbleSize:=False, _
                            Separator:="" & Chr(13) & ""
                    End With
                Next
            End With
        End If
        End With
    End If 'End to if not sheet is handled
    DataRow = DataRow + 1
    Loop

End Sub

Public Function StringExistsInCollection(ByRef aCollection As Collection, item As String) As Boolean
    StringExistsInCollection = False
    For i = 1 To aCollection.Count
        If aCollection(i) = item Then
            StringExistsInCollection = True
            Exit Function
        End If
    Next i
End Function

2

solved Excel VBA error: “cannot complete task with available resources”