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
不，我想查看您的工作簿。我想檢查這些形狀 –