Excel VBA 脚本中的对象定义错误
Object Defined error in Excel VBA script
我正在尝试构建一个脚本来提取列（用户定义）的前 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
很可能 sht 为空。
你 Dim sht as Worksheet 但从来没有 Set 它对任何东西。您的错误行是使用 sht 的第一行，因此它恰好是引起您注意错误的地方。
我认为您可能希望将其设置为与 dest 范围关联的 sheet。
set sht = dest.Worksheet
尽管如此，您在处理 cols 时需要注意不要重用该变量（您可能会考虑重命名这些变量以更明确地说明它们在做什么，但这是另一回事）。在您设置 dest 和 rng 的方式中，不能保证它们来自同一个 sheet，这在设置 col 与 cols 时会导致问题。如果您尝试用不同 sheets.
上的单元格组成一个范围，则会出现异常
在相关说明中，您可以使用 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
我正在尝试构建一个脚本来提取列（用户定义）的前 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
很可能 sht 为空。
你 Dim sht as Worksheet 但从来没有 Set 它对任何东西。您的错误行是使用 sht 的第一行，因此它恰好是引起您注意错误的地方。
我认为您可能希望将其设置为与 dest 范围关联的 sheet。
set sht = dest.Worksheet
尽管如此，您在处理 cols 时需要注意不要重用该变量（您可能会考虑重命名这些变量以更明确地说明它们在做什么，但这是另一回事）。在您设置 dest 和 rng 的方式中，不能保证它们来自同一个 sheet，这在设置 col 与 cols 时会导致问题。如果您尝试用不同 sheets.
在相关说明中，您可以使用 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