问题
I am getting this run-time error "The index into the specified collection is out of bounds."
The goal is to remove all objects from my worksheet. I was using the code below for quite some time and it worked fine before it suddenly started triggering the error.
Dim obj As Shape
For Each obj In .Shapes
obj.Delete
Next obj
I did research online and found that looping backwards seemed to solve the problem for most people.
'Delete all objects on sheet
For i = ThisWorkbook.Sheets("Req Raw").Shapes.count To 1 Step -1
ThisWorkbook.Sheets("Req Raw").Shapes(i).Delete
Next
However, even with this code the error seems to persist, even with empty sheets with no objects. The sheet is not protected. On debug, the line in question seems to be the line with delete
Edit: Full code
The goal of this code is to take a table from the user's clipboard and paste it into an excel sheet called "Req Raw". It then reformats the table to a conformed format and copies a few values to a seperate sheet called 'Values'
Before any of the formatting can take place, the script bugs out due to the .shapes.delete line. It used to function properly and I had moved on in my script and hadn't even touched it in a few days. Now it is giving me the run-time error.
Private Sub R2OK_Click()
'~~~> Variables
'Table Formatting Variables
Dim HC As Integer
Dim RID As Range
Dim RCount As Range
Dim RC As Integer
Dim RCon As Range
Dim RCon2 As Range
Dim CCount As Range
'Destination Cell
Dim MCell As Range
'End Rows
Dim EndR As Range
Dim cacheR As Range
'Object deletion
Dim obj As Shape
'ID Req Raw Rows
Dim SecT As Range
Dim IDCount As Integer
Dim IDF As String
'Values List
Dim VSection As Range
Dim VName As Range
Dim VType As Range
Dim VID As Range
'~~~> Set Active Sheet to Req Raw
With ThisWorkbook.Sheets("Req Raw")
'~~~> Paste DRS from Clipboard to empty row
'Find next empty row
HC = 2
For Each RCount In Range("'Req Raw'!$A$" & HC & ":$A$50000")
If RCount.Value <> 0 And RCount.Value <> "" Then
HC = HC + 1
ElseIf RCount = 0 Or RCCount = "" Then
Exit For
End If
Next RCount
'Paste into empty cell
ActiveSheet.Paste Destination:=Worksheets("Req Raw").Range("$B$" & HC)
'Clear clipboard
Application.CutCopyMode = False
'Unmerge cells
.Cells.UnMerge
'Delete all objects on sheet
For i = ThisWorkbook.Sheets("Req Raw").Shapes.count To 1 Step -1
ThisWorkbook.Sheets("Req Raw").Shapes(i).Delete '~~~PROBLEM LINE~~~
'For Each obj In .Shapes
'obj.Delete
'Next obj
Next
'Find empty header columns and consolidate column contents where contents are marked by borders
For Each CCount In Range("'Req Raw'!$AB$2:$B$2")
If CCount.Value = "" Or CCount.Value = 0 Then
For Each RCon In .Range(.Cells(3, CCount.Column), .Cells(.Cells(Rows.count, CCount.Column).End(xlUp).Row, CCount.Column))
If RCon.Value <> "" And RCon.Value <> 0 Then
'Check to see that a cell within the word table row has not been split. If so, move cell contents to the cell above before merging across
If RCon.Borders(xlEdgeBottom).LineStyle <> xlNone Then
ElseIf RCon.Borders(xlEdgeBottom).LineStyle = xlNone Then
For Each RCon2 In .Range(.Cells(RCon.Offset(1).Row, CCount.Column), .Cells(.Cells(Rows.count, CCount.Column).End(xlUp).Row, CCount.Column))
If RCon2.Borders(xlEdgeBottom).LineStyle <> xlNone Then
If RCon2.Value <> "" And RCon2.Value <> 0 Then
RCon.Value = RCon.Value & vbNewLine & RCon2.Value
RCon2.ClearContents
End If
Exit For
ElseIf RCon2.Borders(xlEdgeBottom).LineStyle = xlNone And RCon2.Value <> "" And RCon2.Value <> 0 Then
RCon.Value = RCon.Value & vbNewLine & RCon2.Value
RCon2.ClearContents
End If
Next RCon2
End If
End If
Next RCon
'If next column is a header column, check to see if data needs to be moved in that column
If CCount.Offset(columnOffset:=-1).Value <> "" And CCount.Offset(columnOffset:=-1).Value <> 0 Then
Set RCon = Nothing
Set RCon2 = Nothing
For Each RCon In .Range(.Cells(3, CCount.Column), .Cells(.Cells(Rows.count, CCount.Column).End(xlUp).Row, CCount.Column))
If RCon.Value <> "" And RCon.Value <> 0 Then
'Check to see that a cell within the word table row has not been split. If so, move cell contents to the cell above before merging across
If RCon.Offset(columnOffset:=-1).Borders(xlEdgeBottom).LineStyle <> xlNone Then
ElseIf RCon.Offset(columnOffset:=-1).Borders(xlEdgeBottom).LineStyle = xlNone Then
For Each RCon2 In .Range(.Cells(RCon.Offset(1).Row, CCount.Offset(columnOffset:=-1).Column), .Cells(.Cells(Rows.count, CCount.Offset(columnOffset:=-1).Column).End(xlUp).Row, CCount.Offset(columnOffset:=-1).Column))
If RCon2.Borders(xlEdgeBottom).LineStyle <> xlNone Then
If RCon2.Value <> "" And RCon2.Value <> 0 Then
RCon.Offset(columnOffset:=-1).Value = RCon.Offset(columnOffset:=-1).Value & vbNewLine & RCon2.Value
RCon2.ClearContents
End If
Exit For
ElseIf RCon2.Borders(xlEdgeBottom).LineStyle = xlNone And RCon2.Value <> "" And RCon2.Value <> 0 Then
RCon.Offset(columnOffset:=-1).Value = RCon.Offset(columnOffset:=-1).Value & vbNewLine & RCon2.Value
RCon2.ClearContents
End If
Next RCon2
End If
End If
Next RCon
End If
End If
Next CCount
'Find empty header columns and move data from left to right until header is not blank, while deleting empty cells
Set CCount = Nothing
Set RCon = Nothing
For Each CCount In Range("'Req Raw'!$AB$2:$B$2")
If CCount.Value = "" Or CCount.Value = 0 Then
For Each RCon In .Range(.Cells(3, CCount.Column), .Cells(.Cells(Rows.count, CCount.Column).End(xlUp).Row, CCount.Column))
If RCon.Value <> "" And RCon.Value <> 0 Then
RCon.Offset(columnOffset:=-1).Value = RCon.Offset(columnOffset:=-1).Value & vbNewLine & RCon.Value
If CCount.Offset(columnOffset:=-1).Value <> "" And CCount.Offset(columnOffset:=-1).Value <> 0 Then
RCon.Offset(columnOffset:=-1).Value = RCon.Offset(columnOffset:=-1).Value & vbNewLine
End If
End If
Next RCon
CCount.EntireColumn.Delete
End If
Next CCount
''Row Management Begins
Set CCount = Nothing
Set RCon = Nothing
RC = HC + 1
'Check for empty row between header and first testcase
Do
Set RID = Range("'Req Raw'!$B$" & RC)
If RID = "" Or RID = 0 Then
For Each CCount In Range("'Req Raw'!$B$2:$AB$2")
If CCount.Offset(1).Value <> "" And CCount.Offset(1).Value <> 0 Then
CCount.Value = CCount.Value & vbNewLine & CCount.Offset(1).Value
End If
If CCount.Value = 0 Or CCount.Value = "" Then Exit For
Next CCount
CCount.Offset(1).EntireRow.Delete
Set CCount = Nothing
End If
Set RID = Range("'Req Raw'!$B$" & RC)
Loop Until RID <> "" And RID <> 0
'Loop for each Test Case
Do Until RC = 0
'Find end row (end of requirement)
For Each EndR In Range("'Req Raw'!$B$" & (RC + 1) & ":$B$" & (RC + 101))
If EndR <> "" And EndR <> 0 Then Exit For
If EndR.Row = RC + 101 Then
Set cacheR = Range("'Values'!$B$3")
For Each CCount In Range("'Req Raw'!$B$2:$AB$2")
cacheR.Offset(columnOffset:=1).Value = Worksheets("Req Raw").Cells(Rows.count, CCount.Column).End(xlUp).Row
cacheR = Application.WorksheetFunction.Max(cacheR.Value, cacheR.Offset(columnOffset:=1).Value)
'If CCount (Header) is blank, then exit
If CCount.Value = 0 Or CCount.Value = "" Then Exit For
Next CCount
Set EndR = Range("'Req Raw'!$A$" & cacheR.Value)
Exit For
End If
Next EndR
Set CCount = Nothing
'Consolidate cell contents (rows)
'For Each Column
For Each CCount In Range("'Req Raw'!$B$2:$AB$2")
'Where CCount (Header) is not blank
If CCount.Value <> 0 And CCount.Value <> "" Then
'Set destination cell in CCount column
Set MCell = Sheets("Req Raw").Cells(RC, CCount.Column)
'For Each cell in CCount Column within RC (Header) + 1 and EndR Row (Next Header) - 1
For Each RCon In .Range(.Cells(RC, CCount.Column), .Cells(EndR.Row - 1, CCount.Column))
'Range ("'Req Raw'!" & CCount.Columns(1) & (RC + 1) & ":" & CCount.Columns(1) & (EndR.Row - 1))
'Skip if RCon = MCell
If MCell.Value = RCon.Value Then
'Skip if this cell and the next are blank
ElseIf (RCon.Value = 0 Or RCon.Value = "") And (RCon.Offset(1).Value = 0 Or RCon.Offset(1).Value = "") Then
'Add cell contents to MCell
Else: MCell.Value = MCell.Value & vbNewLine & RCon.Value
End If
Next RCon
'If CCount (Header) is blank, then exit
ElseIf CCount.Value = 0 Or CCount.Value = "" Then
Exit For
End If
Next CCount
'Delete extra rows
If RC + 1 = EndR.Row Then
ElseIf RC + 1 <> EndR.Row Then Range("'Req Raw'!$A$" & (RC + 1) & ":$A$" & (EndR.Row - 1)).EntireRow.Delete
End If
'Set up for next test case
RC = RC + 1
'Primary Loop Exit
If Range("'Req Raw'!$B$" & RC).Value = "" Then Exit Do
Loop
'~~~> For Each Row
'~~~> ID Row (offset by 2 columns) with SectionTitle (Cache A3) + ID starting with 0 on the header
Set RID = Nothing
Set SecT = Range("'Values'!$A$3")
Set RCount = .Range(.Cells(HC, 2), .Cells(.Cells(Rows.count, 2).End(xlUp).Row, 2))
IDCount = 0
For Each RID In RCount
'ID Req rows
IDF = CStr(IDCount)
IDF = Format(IDF, "0000")
RID.Offset(columnOffset:=-1).Value = SecT.Value & " " & IDF
'~~~> Add ID, ReqName, Section to Values sheet where if ID is 0 then Type = Folder
Set VSection = Worksheets("Values").Cells(Worksheets("Values").Cells(Rows.count, 2).End(xlUp).Row + 1, 2)
VSection.EntireRow.ClearContents
Set VName = Worksheets("Values").Cells(Worksheets("Values").Cells(Rows.count, 2).End(xlUp).Row + 1, 3)
Set VType = Worksheets("Values").Cells(Worksheets("Values").Cells(Rows.count, 2).End(xlUp).Row + 1, 4)
Set VID = Worksheets("Values").Cells(Worksheets("Values").Cells(Rows.count, 2).End(xlUp).Row + 1, 5)
'Row = Header where IDCount = 0
If IDCount = 0 Then
VSection.Value = SecT.Value
VName.Value = SecT.Value
VType.Value = "Folder"
VID.Value = IDCount
'Row <> Header where IDCount > 0
ElseIf IDCount > 0 Then
VSection.Value = SecT.Value
If InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) <> 0 And (InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) - 1) >= 10 Then
VName.Value = RID.Value & " " & Left(RID.Offset(columnOffset:=1).Value, InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) - 1)
Else: VName.Value = RID.Value & " " & RID.Offset(columnOffset:=1).Value
End If
VName.Value = Replace(VName.Value, vbCrLf, " ")
VName.Value = Replace(VName.Value, " ", " ")
VName.WrapText = False
VID.Value = IDCount
End If
IDCount = IDCount + 1
Next RID
'~~~> Sort DRS by ID
.Range(.Cells(2, 1), .Cells(.Cells(Rows.count, 1).End(xlUp).Row, .Cells(2, Columns.count).End(xlUp).Column)).Sort key1:=.Range(.Cells(2, 1), .Cells(.Cells(Rows.count, 1).End(xlUp).Row, 1)), order1:=xlAscending, Header:=xlNo
'~~~> Sort Values sheet range by ID
With Worksheets("Values")
.Range(.Cells(15, 2), .Cells(50000, 12)).Sort key1:=.Range(.Cells(15, 2), .Cells(50000, 2)), order1:=xlAscending, Header:=xlNo
End With
End With
'~~~> Reset
Unload Me
Unload ReqUploadForm
ReqUploadForm.Show
'~~~> Clear Cache
Dim Cache As Range
Set Cache = Range("'Values'!$A$3:$D$12")
Cache.ClearContents
End Sub回答1:
Seems like deleting pictures seperately before deleting all shapes addresses the issue. Below is the code I used.
'Delete all objects on sheet
.Pictures.Delete
For i = .Shapes.count To 1 Step -1
.Shapes(i).Delete
Next
来源：https://stackoverflow.com/questions/30330897/excel-vba-deleting-objects-from-sheet-triggers-run-time-error