“下标超出范围”错误，并且需要复制并粘贴标题行来创build数据透视表

我有以下代码将复制并粘贴来自Sheet1行E列中符合关键字条件（Milestone）的行，并将行复制到Sheet2。

date然后提取Sheet2并input到一个新的列，但我收到错误

下标超出范围（错误9）

当这个动作完成时。

我看不到是什么原因造成的？

我还需要首先将Sheet1中的第10行复制并粘贴到Sheet2中的第1行以用作数据透视表的类别？

Sub mileStoneDateChanger() Dim r As Long, pasteRowIndex As Long, v() As Long, i As Long Dim lastRow As Long Dim lCol As Long lastRow = Cells.Find(What:="*", _ After:=Range("A1"), _ LookAt:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row MsgBox "Last Row: " & lastRow pasteRowIndex = 1 With Sheets("Sheet1") For r = 1 To lastRow If .Cells(r, "E").Value Like "Milestone*" Then If UBound(Split(.Cells(r, "E"), ",")) > 0 Then i = i + 1 ReDim v(1 To i) v(i) = pasteRowIndex End If Sheets("Sheet1").Rows(r).Copy Sheets("Sheet2").Rows(pasteRowIndex) pasteRowIndex = pasteRowIndex + 1 End If Next r End With With Sheets("Sheet2") newLastRow = Cells.Find(What:="*", _ After:=Range("B1"), _ LookAt:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row If IsArray(v) Then .Columns(6).Insert shift:=xlToRight For i = 1 To newLastRow .Cells(i, "F").Value = Split(.Cells(i, "E"), ",")(1) Next i End If End With End Sub 

Answer 1

你正在得到超出范围的错误，因为你认为你在这里有一个逗号（在Cells(i,"E") ：

 For i = 1 To newLastRow .Cells(i, "F").Value = Split(.Cells(i, "E"), ",")(1) Next i 

通过上面的代码，你可以用逗号从分解的Cells(i,"E")数组的第二个值。 如果单元格中的值是123,45 ，则需要45 。 很可能有一个情况，你没有任何逗号，因此没有第二个值。 所以，你必须做一个检查。 比如像这样的东西：

 If InStr(1, .Cells(i, "F"), ",") Then .Cells(i, "F").Value = Split(.Cells(i, "E"), ",")(1) End If