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

我试图build立一个脚本，提取列的前6个字符（用户定义），并插入一个新的列，并粘贴这些结果，或只是通过已经存在的列（用户的select），但我不断得到一个结果对象定义错误（我用星号在代码中标记了行）。

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

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 & _ " (eg 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 & _ " (eg 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为null。

你Dim sht as Worksheet但从来没有Set它Set为任何东西。 你的错误行是使用sht的第一行，所以恰好是错误引起你注意的地方。

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

 set sht = dest.Worksheet 

但是，在处理cols时，你需要小心不要重复使用这个variables（你可能会考虑重命名这些variables来明确自己在做什么，但这是另一回事）。 按照设置dest和rng方式，不能保证在设置col和col时会导致问题。 如果您尝试在不同的工作表上使用单元格编写范围，则会发生exception。

Answer 2

在相关说明中，通过使用VBA的TextToColumn方法 ，可以非常快速地将六个最左边的字符放到整个列中，select第一个字段宽度为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 & _ " (eg 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 & _ " (eg 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