Excel VBA - 从 sheet 中删除对象会触发 运行-time 错误
Excel VBA - Deleting objects from sheet triggers run-time error
我收到这个 运行 时间错误 "The index into the specified collection is out of bounds."
目标是从我的作品中删除所有对象sheet。
我使用下面的代码已经有一段时间了，在它突然开始触发错误之前它运行良好。
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
但是，即使使用此代码，错误似乎仍然存在，即使 sheet 没有任何对象也是如此。 sheet 不受保护。在调试时，有问题的行似乎是 delete
编辑：完整代码
此代码的目标是从用户的剪贴板中取出 table 并将其粘贴到名为 "Req Raw" 的 excel sheet 中。然后它将 table 重新格式化为一致的格式，并将一些值复制到名为 'Values'
的单独 sheet
在进行任何格式设置之前，脚本因 .shapes.delete 行而出错。它曾经正常运行，我已经在我的脚本中继续前进，甚至几天都没有碰过它。现在它给我 运行-time 错误。
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 & ":$A000")
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:$B")
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:$B")
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:$AB")
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")
For Each CCount In Range("'Req Raw'!$B:$AB")
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:$AB")
'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")
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:$D")
Cache.ClearContents
End Sub
似乎在删除所有形状之前单独删除图片解决了这个问题。下面是我使用的代码。
'Delete all objects on sheet
.Pictures.Delete
For i = .Shapes.count To 1 Step -1
.Shapes(i).Delete
Next
我收到这个 运行 时间错误 "The index into the specified collection is out of bounds."
目标是从我的作品中删除所有对象sheet。 我使用下面的代码已经有一段时间了，在它突然开始触发错误之前它运行良好。
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
但是，即使使用此代码，错误似乎仍然存在，即使 sheet 没有任何对象也是如此。 sheet 不受保护。在调试时，有问题的行似乎是 delete
编辑：完整代码
此代码的目标是从用户的剪贴板中取出 table 并将其粘贴到名为 "Req Raw" 的 excel sheet 中。然后它将 table 重新格式化为一致的格式，并将一些值复制到名为 'Values'
的单独 sheet在进行任何格式设置之前，脚本因 .shapes.delete 行而出错。它曾经正常运行，我已经在我的脚本中继续前进，甚至几天都没有碰过它。现在它给我 运行-time 错误。
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 & ":$A000")
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:$B")
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:$B")
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:$AB")
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")
For Each CCount In Range("'Req Raw'!$B:$AB")
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:$AB")
'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")
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:$D")
Cache.ClearContents
End Sub
似乎在删除所有形状之前单独删除图片解决了这个问题。下面是我使用的代码。
'Delete all objects on sheet
.Pictures.Delete
For i = .Shapes.count To 1 Step -1
.Shapes(i).Delete
Next