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

与错误相关的Dropbox文件

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

此脚本的目标是基于“当前位置（列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

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

1 个答案: