Создание нового листа работает только сначала, а для следующих данных выдается ошибка «Run Time Error 9»

Question

Я пытаюсь создать программу, которая будет копировать строку на основе значения в столбце P на другой лист в той же книге. Столбец P может быть:

Дизайн

Производство

Процесс

Безопасность

Качество

Закупки

Я хочу, чтобы программа посмотрела на столбец P, и если он говорит «дизайн», скопируйте и вставьте эту строку в лист с надписью «Дизайн» и т. Д. И т. Д.

Может кто-нибудь помочь мне?

Линия

Set tosheet = Worksheets("" & fromsheet.Cells(r, "P"))

сначала работает нормально, затем выдает ошибку 'Run Time Error 9 после первой итерации.

Sub lars_ake_copy_rows_to_sheets()
Dim firstrow, lastrow, r, torow As Integer
Dim fromsheet, tosheet As Worksheet
firstrow = 2
Set fromsheet = ActiveSheet
lastrow = ActiveSheet.Cells(Rows.Count, "P").End(xlUp).Row
  For r = firstrow To lastrow
    If fromsheet.Cells(r, "P") <> "" Then  'skip rows where column P is empty
     On Error GoTo make_new_sheet
     Set tosheet = Worksheets("" & fromsheet.Cells(r, "P"))
     On Error GoTo 0
     GoTo copy_row
  make_new_sheet:
  Set tosheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  tosheet.Name = fromsheet.Cells(r, "P")
copy_row:
  torow = tosheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
  fromsheet.Cells(r, 1).EntireRow.Copy
  tosheet.Cells(torow, 1).PasteSpecial Paste:=xlPasteValues
End If
Next r
 Application.CutCopyMode = False
 fromsheet.Activate

End Sub

Я хочу, чтобы этот код создавал новый лист, если он еще не создан.

Но этот код создает новый лист только для 1-й записи столбца p, которая является дизайном, если этот лист создан не ранее, а для следующей записи. То есть «Производство», если рабочий лист с именем «Производство» не был создан ранее, тогда этот код выдает ошибку «Время выполнения 9. Любой, кто может это исправить для меня.

»

Answer 1

Как я уже упоминал в моем комментарии, вы неправильно обрабатываете "Выход из обработчика ошибок". Вы можете посмотреть Хорошие шаблоны для обработки ошибок VBA для получения подробной информации о том, как обрабатывать ошибки.

Этот код должен решить вашу проблему (но я ее не тестировал)

Sub lars_ake_copy_rows_to_sheets()
    Dim firstrow As Long, lastrow As Long, r As Long, torow As Long
    Dim fromsheet As Worksheet, tosheet As Worksheet
    firstrow = 2
    Set fromsheet = ActiveSheet
    lastrow = ActiveSheet.Cells(Rows.Count, "P").End(xlUp).Row
    For r = firstrow To lastrow
        If fromsheet.Cells(r, "P") <> "" Then  'skip rows where column P is empty
            On Error GoTo make_new_sheet
            Set tosheet = Worksheets("" & fromsheet.Cells(r, "P"))
            On Error GoTo 0
            torow = tosheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
            fromsheet.Cells(r, 1).EntireRow.Copy
            tosheet.Cells(torow, 1).PasteSpecial Paste:=xlPasteValues
        End If
    Next r
    Application.CutCopyMode = False
    fromsheet.Activate
    Exit Sub
make_new_sheet:
    Set tosheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    tosheet.Name = fromsheet.Cells(r, "P")
    resume next
End Sub