運行時錯誤'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工作表具有這樣的信息

例子

與錯誤相關的Dropbox文件

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

該腳本的目標是基於“當前位置（M列）”在工作表中創建新選項卡。 我有多個當前位置（可能超過100個）。 然后它將復制與Column MEg有關的所有數據在洛杉磯的所有內容，並復制到Los Angeles Tab。

謝謝。

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