运行时错误'9'。在Excel VBA

Question

子脚本超出范围的错误，我得到一个

运行时错误“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工作表我试图把它从有这样

Example信息。有关错误

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

这个脚本的目标

Dropbox的文件是基于“当前位置（列M）”，在工作表中创建新的标签。我有多个当前位置（可能是100+）。然后它会复制与列M有关的所有数据。洛杉矶的所有东西都会被复制到洛杉矶标签。

谢谢。

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