運行時錯誤'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