运行时错误“9”。 Excel VBA中的子脚本超出范围错误

我正在得到一个

运行时错误“9”：子脚本超出范围。

Option Explicit Sub DistributeRows() Dim a As Variant, h As String Dim i As Long, nr As Long Dim rng As Range, c As Range, v Application.ScreenUpdating = False With Sheets("Sheet1") a = .Cells(1).CurrentRegion Set rng = .Range("M2:M" & UBound(a, 1)) End With With CreateObject("Scripting.Dictionary") .CompareMode = vbTextCompare For Each c In rng If c <> "" Then If Not .Exists(c.Value) Then .Add c.Value, c.Value End If End If Next v = Application.Transpose(Array(.keys)) End With For i = LBound(v) To UBound(v) h = v(i, 1) If Not WorksheetExists(h) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h Sheets(h).Range("A1").Resize(, UBound(a, 2)).Value = Sheets("Sheet1").Range("A1").Resize(, UBound(a, 2)).Value End If Next i For i = 2 To UBound(a, 1) h = a(i, 3) nr = Sheets(h).Range("A" & Rows.Count).End(xlUp).Offset(1).Row Sheets(h).Range("A" & nr).Resize(, 3).Value = Sheets("Sheet1").Cells(i, 1).Resize(, 3).Value Sheets(h).Columns.AutoFit Next i Sheets("Sheet1").Activate Application.ScreenUpdating = True End Sub Function WorksheetExists(WSName As String) As Boolean On Error Resume Next WorksheetExists = Worksheets(WSName).Name = WSName On Error GoTo 0 End Function 

我收到这一行的错误。

nr = Sheets(h).Range("A" & Rows.Count).End(xlUp).Offset(1).Row

我试图从中拉出的Excel表有这样的信息

例子 。

与错误相关的Dropbox文件

https://dl.dropboxusercontent.com/u/64819855/StackOverflow.xlsx

此脚本的目标是基于“当前位置（列M）”在工作表中创build新选项卡。 我有多个当前位置（可能是100+）。 然后它会复制所有有关列MEg洛杉矶一切的数据，将被复制到洛杉矶标签。

谢谢。

Answer 1

我修改了代码，明白了问题所在。 这里是更新的代码，如果你们需要做类似的事情 – 希望这会有所帮助。

 Option Explicit Sub DistributeRows() Dim a As Variant, h As String Dim i As Long, nr As Long Dim rng As Range, c As Range, v Application.ScreenUpdating = False //Change Range("XX#:X" to whatever you want to create new tabs from. With Sheets("Sheet1") a = .Cells(1).CurrentRegion Set rng = .Range("M2:M" & UBound(a, 1)) End With With CreateObject("Scripting.Dictionary") .CompareMode = vbTextCompare For Each c In rng If c <> "" Then If Not .Exists(c.Value) Then .Add c.Value, c.Value End If End If Next v = Application.Transpose(Array(.keys)) End With For i = LBound(v) To UBound(v) h = v(i, 1) If Not WorksheetExists(h) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h Sheets(h).Range("A1").Resize(, UBound(a, 2)).Value = Sheets("Sheet1").Range("A1").Resize(, UBound(a, 2)).Value End If Next i For i = 2 To UBound(a, 1) h = a(i, 13) nr = Sheets(h).Range("A" & Rows.Count).End(xlUp).Offset(1).Row Sheets(h).Range("A" & nr).Resize(, 16).Value = Sheets("Sheet1").Cells(i, 1).Resize(, 16).Value Sheets(h).Columns.AutoFit Next i // Change the Resize(, XX) to whatever you want to copy until. // Also change the H = a(i,XX) to whatever column your "tab names" are at. // Sheets("Sheet1").Activate Application.ScreenUpdating = True End Sub Function WorksheetExists(WSName As String) As Boolean On Error Resume Next WorksheetExists = Worksheets(WSName).Name = WSName On Error GoTo 0 End Function