Объект Определенная ошибка в скрипте Excel VBA

Question

Я пытаюсь создать сценарий, который извлекает первые 6 символов столбца (определяется пользователем) и либо вставляет новый столбец, и вставляет эти результаты, либо просто проходит эти результаты по уже существующему column (выбор пользователя), но я продолжаю получать ошибку определения объекта (я отметил строку в коде звездочками).

Может ли кто-нибудь сказать мне, что я делаю неправильно? Вот мой код

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 null.

Вы Dim sht as Worksheet, но никогда Set это ни к чему. Строка вашей ошибки - это первая строка, которая использует sht, поэтому это просто место, где ошибка доведена до вашего сведения.

Я бы похудел, вам нужно было установить его на лист, связанный с диапазоном dest.

set sht = dest.Worksheet 

Вам нужно быть осторожным, чтобы не использовать повторно эту переменную при работе с cols хотя (вы можете рассмотреть вопрос о переименовании тех, более четко о том, что они делают, но это другой вопрос). В способе, которым вы устанавливаете dest и rng, они не гарантированы от того же листа, что может вызвать проблемы при установке col по сравнению с cols. Вы получите исключение, если попытаетесь составить диапазон с ячейками на разных листах.

Answer 2

На соответствующую записку, вы можете очень быстро получить шесть самые левые символы в целые колонки с помощью VBA-х TextToColumn method, выбирая первое поле шириной и отбрасывая любое другое поле. Для длинных столбцов значений это должно заметно изменить цикл и вывести первые шесть символов каждой ячейки.

В нижней части вашего поставленного кода имеется следующий цикл.

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

Это, казалось бы иметь цв определяются как назначения первых шести символов из исходного столбца Cols. Вы прокручиваете каждую ячейку и очищаете первые шесть символов.

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

Это передает значения из перевалов к цв затем срывает ничего мимо шестой символ всего пути через колонку сразу.

Для чего-либо менее нескольких сотен значений, я не знаю, буду ли я беспокоиться о переписывании, но эффективность увеличит количество строк, которые вы должны обработать.

Отрывок Реализация:

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