Excel VBA 脚本中的对象定义错误

Question

我正在尝试构建一个脚本来提取列的前 6 个字符（用户定义），然后插入一个新列并粘贴这些结果，或者只是将这些结果粘贴到已经存在的列上（用户的选择），但我不断收到对象定义错误（我在代码中用星号标记了该行）。

谁能告诉我我做错了什么？这是我的代码

 Sub AAC_Extract()
    Dim rng As Range, col As Range, arr
    Dim sht As Worksheet, shet As Worksheet

    On Error Resume Next
    Set rng = Application.InputBox( _
                Prompt:="Please select the column that contains the Standard Document Number. " & vbNewLine & _
                        " (e.g. Column A or Column B)", _
                Title:="Select Document Number Range", Type:=8)
    On Error GoTo 0
    hdr = MsgBox("Does your selection contain a header?", vbYesNo + vbQuestion, "Header Option")

    Set dest = Application.InputBox( _
                Prompt:="Please select the column that you would the AAC to be placed in. " & vbNewLine & _
                        " (e.g. Column B or Column C)", _
                Title:="Select Destination Range", Type:=8)

     If dest Is Nothing Then Exit Sub
     Set sht = dest.Worksheet
     Set shet = rng.Worksheet
    'If dest = rng Then
    '    MsgBox "Your Destination Range can not be the same as your Reference Range.  Please choose a valid Destination Range", vbExclamation
    '    Exit Sub
    'End If


     On Error GoTo 0
     yn = MsgBox("Do you want to insert a new column here?" & vbNewLine & _
                        "(Choosing 'No' will replace the current cells in your selected range." & vbNewLine & "All data in this range will be permanently deleted.)", vbYesNo + vbQuestion, "Destination Range Options")


    LastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False
    If hdr = vbYes And yn = vbYes Then
        dest.Select
        With Selection
        .EntireColumn.Insert
        End With
        Set col = sht.Range(sht.Cells(2, dest.Column), _
                        sht.Cells(sht.Rows.Count, dest.Column).End(xlUp))
        Set cols = shet.Range(shet.Cells(2, rng.Column), _
                        shet.Cells(shet.Rows.Count, rng.Column).End(xlUp))
        'Columns = cols.Column
        'dest.EntireColumn.Insert
        'col = dest.Column
        'cols = rng.Column
        'For i = 1 To LastRow
        'Cells(i, col).Value = Left(Cells(i, cols), 6)
        'Next i
        'For Each c In col.Cells.Offset(0, -1) 'Offset due to the fact that dest moved when a column was inserted
        '    i = c.Row
        '    c.Value = Left(cols.Cells(i - 1), 6) 'Honestly, I'm not sure why I have to subtract 1 from i....i should be the same row as c
        'Next c
        With col
        .Value2 = cols.Value2
        .TextToColumns Destination:=.Cells, DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(6, 9))
        End With
    End If

End Sub

Answer 1

sht 很可能为空。

你 Dim sht as Worksheet 但永远不会 Set 它对任何东西。您的错误行是使用sht 的第一行，因此它恰好是引起您注意的错误。

我想你会想将它设置为与dest 范围关联的工作表。

set sht = dest.Worksheet

在处理cols 时，您需要小心不要重用该变量（您可能会考虑重命名这些变量以更明确地说明它们在做什么，但这是另一回事）。在您设置dest 和rng 的方式中，不能保证它们来自同一张表，这在设置col 与cols 时会导致问题。如果您尝试用不同工作表上的单元格组成范围，则会出现异常。

Answer 2

在相关说明中，您可以使用 VBA 的 TextToColumn method 将第一个字段的宽度选择为 6 并丢弃任何其他字段，从而非常快速地将最左边的六个字符放入一整列场地。对于长列值，与循环和提取每个单元格的前六个字符相比，这应该会产生明显的差异。

在您提供的代码的底部附近，您有以下循环。

    For Each c In col.Cells
        c.Value = Left(Cells(i, cols), 6)
    Next c

这似乎将 col 定义为源列 cols 中前六个字符的目标。您遍历每个单元格并剥离前六个字符。

With col
    .Value2 = cols.Value2
    .TextToColumns Destination:=.Cells, DataType:=xlFixedWidth, _
      FieldInfo:=Array(Array(0, 1), Array(6, 9))
End With

这会将值从 cols 转移到 col，然后一次删除第六个字符之后的所有内容。

对于少于几百个值的任何值，我不知道我是否会为重写而烦恼，但效率会增加你必须处理的更多行值。

片段实现：

Sub AAC_Extract()
    Dim rng As Range, col As Range, cols As Range, arr
    Dim sht As Worksheet, shet As Worksheet, hdr As Long, yn As Long, LastRow As Long
    Dim dest As Range

    On Error Resume Next
    Set rng = Application.InputBox( _
                Prompt:="Please select the column that contains the Standard Document Number. " & vbNewLine & _
                        " (e.g. Column A or Column B)", _
                Title:="Select Document Number Range", Type:=8)
    On Error GoTo 0
    hdr = MsgBox("Does your selection contain a header?", vbYesNo + vbQuestion, "Header Option")

    Set dest = Application.InputBox( _
                Prompt:="Please select the column that you would the AAC to be placed in. " & vbNewLine & _
                        " (e.g. Column B or Column C)", _
                Title:="Select Destination Range", Type:=8)

     If dest Is Nothing Then Exit Sub
     Set sht = dest.Parent
     Set shet = rng.Parent

     On Error GoTo 0
     yn = MsgBox("Do you want to insert a new column here?" & vbNewLine & _
                 "(Choosing 'No' will replace the current cells in your selected range." & vbNewLine & _
                 "All data in this range will be permanently deleted.)", vbYesNo + vbQuestion, "Destination Range Options")


    LastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False
    If yn = vbYes Then
        dest.EntireColumn.Insert
        Set dest = dest.Offset(0, -1)
    End If

    'I'm not sure about this because the next set starts in row 2 regardless
    'If hdr = vbYes Then
    '    Set dest = dest.Resize(dest.Rows.Count - 1, 1)
    'End If

    Set cols = shet.Range(shet.Cells(2, rng.Column), _
                    shet.Cells(shet.Rows.Count, rng.Column).End(xlUp))
    Set col = sht.Cells(2, dest.Column).Resize(cols.Rows.Count, 1)

    With col
        .Value2 = cols.Value2
        .TextToColumns Destination:=.Cells, DataType:=xlFixedWidth, _
          FieldInfo:=Array(Array(0, 1), Array(6, 9))
    End With

End Sub