Почему я получаю сообщение об ошибке без ошибки при попытке добавить дополнительную часть к ранее работающему коду?

Question

Мне нужно создать рабочую книгу для каждого уникального кода отдела в столбце основного листа рабочей книги («LastYear») и заполнить лист 1 каждой новой рабочей книги соответствующей информацией для каждого отдела за прошлый год.Если я нашел здесь какой-то код, который позволяет мне это сделать, и он отлично работал.

Мне также нужно выполнить очень похожий процесс для статей в том же отделе для второй вкладки в основной рабочей книге («ThisYear») с другим количеством строк и столбцов к прошлогодним данным.Поэтому вместо того, чтобы создавать новую рабочую книгу для каждого отдела, мне нужно заполнить рабочую таблицу 2 каждой рабочей книги, где отдел совпадает с рабочей таблицей 1.

Я пытался вставить это в код, но яполучаю ошибку «Else Without If», но я уверен, что закрыл каждый из них, если это было уместно, и убедился, что весь код после каждого «Then» находится в новой строке.

Извинения, если я пропустилчто-то очевидное, я так долго искал, что не вижу дрова для деревьев!

Заранее спасибо

Я искал здесь и на других сайтах возможные причины / решенияно ни один из ответов не вполне применим.

             '''''THE BIT I FOUND ON HERE THAT WORKS'''''
Option Explicit

Sub SplitbyDept()
Dim unique(10000) As String, uniqueB(10000) As String
Dim wbNew(10000) As Workbook, Master As Workbook
Dim LastYr As Worksheet, ThisYr As Worksheet, Upload As Worksheet, MainPg As Worksheet
Dim x As Long, y As Long, ct As Long, uCol As Long, xb As Long, yb As Long, ctb As Long, uColb As Long

On Error GoTo ErrHandler

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Source
Set Master = ActiveWorkbook
Set LastYr = Master.Sheets("LastYear")
Set ThisYr = Master.Sheets("ThisYear")

'Unique dept column
uCol = 10

ct = 0

'get a list of unique departments
For x = 2 To LastYr.Cells(LastYr.Rows.Count, uCol).End(xlUp).Row
    If CountIfArray(LastYr.Cells(x, uCol), unique()) = 0 Then
        unique(ct) = LastYr.Cells(x, uCol).Text
        ct = ct + 1
    End If
Next x

'loop through unique
For x = 0 To LastYr.Cells(LastYr.Rows.Count, uCol).End(xlUp).Row - 1

    If unique(x) <> "" Then
        'add workbook
        Set wbNew(x) = Workbooks.Add

        'copy header row
        LastYr.Range(LastYr.Cells(1, 1), LastYr.Cells(1, uCol)).Copy wbNew(x).Sheets(1).Cells(1, 1)

        'loop to find matching departments in LastYr and copy over
        For y = 2 To LastYr.Cells(LastYr.Rows.Count, uCol).End(xlUp).Row
            If LastYr.Cells(y, uCol) = unique(x) Then

               'to copy and paste values
                LastYr.Range(LastYr.Cells(y, 1), LastYr.Cells(y, uCol)).Copy
                wbNew(x).Sheets(1).Cells(WorksheetFunction.CountA(wbNew(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial (xlPasteValues)

            End If
        Next y

           ''''''PART I'M TRYING TO ADD''''''

        'This year unique column
        uColb = ThisYr.Columns(16)

        ctb = 0

        'get a list of unique departments
        For xb = 2 To ThisYr.Cells(ThisYr.Rows.Count, uColb).End(xlUp).Row
            If CountIfArrayb(ThisYr.Cells(xb, uColb), uniqueB()) = 0 Then
                uniqueB(ctb) = ThisYr.Cells(xb, uColb).Text
                ctb = ctb + 1
            End If
        Next xb

        'loop through unique in this year's data
        For xb = 0 To ThisYr.Cells(ThisYr.Rows.Count, uColb).End(xlUp).Row - 1

            If unique(xb) <> "" Then
                'assign worksheet
                Set Upload(xb) = wbNew(x).Sheets(2)

                'copy header row
                ThisYr.Range(ThisYr.Cells(1, 1), ThisYr.Cells(1, uColb)).Copy wbNew(x).Sheets(2).Cells(1, 1)

                'loop to find matching departments in ThisYr and copy over
                For yb = 2 To ThisYr.Cells(ThisYr.Rows.Count, uColb).End(xlUp).Row
                    If ThisYr.Cells(y, uColb) = uniqueB(xb) Then

                       'to copy and paste values
                        ThisYr.Range(ThisYr.Cells(yb, 1), ThisYr.Cells(yb, uColb)).Copy
                        wbNew(x).Sheets(2).Cells(WorksheetFunction.CountA(wbNew(x).Sheets(2).Columns(uColb)) + 1, 1).PasteSpecial (xlPasteValues)

                    End If
                Next yb
            Else

                Exit For

            End If


        'autofit and name
        wbNew(x).Sheets(1).Columns.AutoFit
        wbNew(x).Sheets(2).Columns.AutoFit
        wbNew(x).Sheets(3).Columns.AutoFit
        wbNew(x).Sheets(1).Name = "LastYear_" & unique(x)
        wbNew(x).Sheets(2).Name = "Upload_" & unique(x)
        wbNew(x).Sheets(3).Name = "Merchandiser_Updates"

             '''''END OF PART I'M TRYING TO ADD'''''

        'save when done
        wbNew(x).SaveAs ThisWorkbook.Path & "\" & "categorisation" & unique(x) & " " & Format(Now(), "mm-dd-yy")
        'wbNew(x).Close SaveChanges:=True

    Else '<<<<<<<<<<<<<<<<<<<<<<<<<<<------------------The error is here
    'once reaching blank parts of the array, quit loop
        Exit For
    End If

Next x

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function

Public Function CountIfArrayb(lookup_valueb As String, lookup_arrayb As Variant)
CountIfArrayb = Application.Count(Application.Match(lookup_valueb, lookup_arrayb, 0))
End Function