Solved: Range Error during loop

[JimS]

Below is some code that works fine if there is more then one entry in Column-A (starting at cell A4) on the "List" worksheet.
It will fail if there is only one entry (in cell A4 - only) on the "List" worksheet with a Script out of Range error on the line in RED (it fails when it does the "Next" - it does not fail on that line the first time through).

Any ideas?

Thanks...

JimS




Sub PlotCharts()
Dim NameRange As Range, NameCell As Range
Dim ChartRange As Range, BaseRange As Range, i As Long
Dim CH As Chart
Dim WS As Worksheet

Application.ScreenUpdating = False

Set NameRange = ThisWorkbook.Worksheets("List").Range("A4")
Set NameRange = Range(NameRange, NameRange.End(xlDown))
For Each NameCell In NameRange.Cells
Set WS = ThisWorkbook.Worksheets(NameCell.Value)
i = 1
Set BaseRange = WS.Range("A5", WS.Range("A" & WS.Rows.Count).End(xlUp))
Set ChartRange = BaseRange
Do
If WS.Range("A5").Offset(, i * 6 - 4).Value = "" Then Exit Do
Set ChartRange = Union(ChartRange, BaseRange.Offset(, i * 6 - 4).Resize(, 2))
i = i + 1
Loop While i < 43
Set CH = ThisWorkbook.Charts.Add
With CH
.ChartType = xlColumnClustered
.SetSourceData Source:=ChartRange, PlotBy:=xlColumns
.Location Where:=xlLocationAsNewSheet, Name:=WS.Name & " Chart"
.PlotArea.Interior.ColorIndex = 2
.PlotArea.Width = CH.ChartArea.Width - 15
With .Legend
.Top = 10
.Left = CH.Axes(xlValue).Left + 10
.Height = (i - 1) * 24
.Width = 300
.Shadow = False
.Interior.ColorIndex = xlNone
.Border.LineStyle = x1None

End With
End With

ActiveChart.Deselect

Next

Application.ScreenUpdating = True

End Sub

[mdmackillop]

Your code is OK, it's just that your Range goes to the end of the sheet. Try this simplified version.

Sub PlotCharts()
Dim NameRange As Range, NameCell As Range
Dim ChartRange As Range, BaseRange As Range, i As Long
Dim CH As Chart
Dim WS As Worksheet

Application.ScreenUpdating = False

Set NameRange = ThisWorkbook.Worksheets("List").Range("A4")
'Check size of range
If NameRange.End(xlDown).Row < Rows.Count Then
Set NameRange = Range(NameRange, NameRange.End(xlDown))
End If

For Each NameCell In NameRange.Cells
NameCell.Offset(, 1) = i
i = 1
Next

Application.ScreenUpdating = True

End Sub

[JimS]

That works - Thanks...