0
我收到此运行时错误“指定集合中的索引超出范围”。Excel VBA - 从表格中删除对象触发器运行时错误
目标是从我的工作表中删除所有对象。 我正在使用下面的代码很长一段时间，它突然开始触发错误之前，它工作正常。
Dim obj As Shape
For Each obj In .Shapes
obj.Delete
Next obj
我在网上做过调查，发现后退循环似乎可以解决大多数人的问题。
'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
但是，即使使用此代码，错误似乎仍然存在，即使没有对象的空白工作表也是如此。该表不受保护。在调试阶段，在这个行似乎与delete
编辑线：全码
这段代码的目的是从用户的剪贴板取表，并将其粘贴到名为“REQ一个Excel工作表生的”。然后它将表格重新格式化为一致格式，并将几个值复制到一个单独的名为'Values'的表格
在任何格式化发生之前，由于.shapes.delete行，脚本错误出现。它曾经正常工作，我已经在我的脚本中继续前进，并在几天内甚至没有触及它。现在它给了我运行时错误。
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
它不应该发生。我可以看看你的工作簿吗？ –
添加的代码导致问题 – ssoong
不，我想查看您的工作簿。我想检查这些形状 –