'обработка ошибки при обращении к файлу
Function IsOpenable(AFile As String) As Long

Dim FN As Variant
FN = FreeFile
On Error Resume Next
Open AFile For Input Access Read Lock Read Write As #FN
IsOpenable = Err.Number
Close #FN

End Function

Sub ЗагрузкаЗадач()

'Код построен без учета дублирующихся ID задач, т.е. они все уникальны
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False

Dim FPath As String

With Application.FileDialog(msoFileDialogOpen) 'открываем диалоговое окно
.Title = "Выберите файл для загрузки!"
.ButtonName = "Загрузить"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Отчет_Битрикс24", "*.xls", 1
If .Show = -1 Then
FPath = .SelectedItems(1) ' & "/"

'проверяем возможность открытия файла
Select Case IsOpenable(FPath)
Case 70:
MsgBox "Закройте выбранный файл!", vbInformation, "Сообщение"
Exit Sub
Case 53, 76:
MsgBox "Выбранный файл отсутствует!", vbInformation, "Сообщение"
Exit Sub
Case 0:
Case Else:
MsgBox "Файл не может быть открыт!", vbCritical, "Ошибка!"
Exit Sub
End Select

Application.Workbooks.Open Filename:=FPath, Notify:=False '.Execute

'запоминаем имя файла отчета для сохранения в дальнейшем
Dim FName As String
FName = ActiveWorkbook.Name

'определяем номер последней строки ID в отчете
Dim LRow As Long
LRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim ARow As Long
Dim XRow As Long
Dim ID As String
Dim IDP As String
Dim IDRng As Range
Dim TLevelRng As Range
Dim TLevelCol As Integer
Dim TStatus As String

With ActiveWorkbook.ActiveSheet
'проверка на пустое ID на всякий случай, такого быть не должно, но если есть, то это ошибка в загружаемом отчете
Set IDRng = .Range("A2:A" & LRow).Find(what:="", LookIn:=xlValues, lookAt:=xlWhole)
If Not IDRng Is Nothing Then
MsgBox "Обнаружено незаполненное поле ID в загружаемом отчете!", vbCritical, "Ошибка"
IDRng.Select
Exit Sub
End If
End With

With ThisWorkbook.Sheets("Задачи")
'проверка на пустое ID в задачах, такого быть не должно, но если есть, то это ошибка в файле-приемнике - задачах
Set IDRng = .Range("ЗадачиНомера").Find(what:="", LookIn:=xlValues, lookAt:=xlWhole)
If Not IDRng Is Nothing Then
MsgBox "Обнаружен незаполненный номер в задачах!", vbCritical, "Ошибка"
.Activate
.Rows(IDRng.Row).Select
Exit Sub
End If
'проверка на пустое поле в уровнях в задачах, такого быть не должно, но если есть, то это ошибка в файле-приемнике - задачах
Set TLevelRng = .Range("ЗадачиУровни").Find(what:="", LookIn:=xlValues, lookAt:=xlWhole)
If Not TLevelRng Is Nothing Then
MsgBox "Обнаружена задача с незаполненным наименованием!", vbCritical, "Ошибка"
.Activate
.Rows(TLevelRng.Row).Select
Exit Sub
End If

Dim ImportVar As String 'Размещение задач снизу или сверху
Dim ImportStatus1 As String 'Статус 1
Dim ImportStatus2 As String 'Статус 2
Dim ImportEval As String 'Оценка

With ThisWorkbook.Sheets("Справочник")
ImportVar = .Range("ПорядокИмпортаЗадачРазмещение").Value
ImportStatus1 = .Range("ПорядокИмпортаЗадачСтатус1").Value
ImportStatus2 = .Range("ПорядокИмпортаЗадачСтатус2").Value
ImportEval = .Range("ПорядокИмпортаЗадачОценка").Value
End With

'перебираем каждый ID в отчете и ищем в задачах
For ARow = 2 To LRow
'пропускаем итерацию при выбранных условиях порядка импорта в справочнике
If Cells(ARow, 7).Value = ImportStatus1 Or Cells(ARow, 7).Value = ImportStatus2 Or Cells(ARow, 15).Value = ImportEval Then
GoTo Continue
End If

ID = Cells(ARow, 1).Value

'полученный ID в отчете ищем в этой книге в задачах
Set IDRng = .Range("ЗадачиНомера").Find(what:=ID, LookIn:=xlValues, lookAt:=xlWhole)

'если не нашли, ищем ID родителя, т.к. возможно следует включить задачу к существующей, как подчиненную, если будет найден родитель
If IDRng Is Nothing Then
IDP = Cells(ARow, 2).Value
Set IDRng = .Range("ЗадачиНомера").Find(what:=IDP, LookIn:=xlValues, lookAt:=xlWhole)

'если не нашли ID родителя или ID родителя пустое в отчете
If IDRng Is Nothing Or IDP = "" Then

TLevelCol = 8 'указываем столбец задачи 1 уровня, чтобы вставить ее наименование
TStatus = "Создана новая задача " & ID

If ImportVar = "Сверху" Then
'если выбран вариант загрузки Сверху, указываем первую строку задачи для вставки новой задачи первого уровня
XRow = 7 'вставляем сверху
End If
If ImportVar = "Снизу" Then
'если выбран вариант загрузки Снизу, указываем следующую за последней строкой задачи для вставки новой задачи первого уровня
XRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'Range("ЗадачиID").Count + 1 'вставляем снизу
End If

'если нашли ID родителя
Else

TLevelCol = 7 + .Cells(IDRng.Row, 2).Value + 1
TStatus = "Создана новая подчиненная задача " & ID & " к " & IDP

If ImportVar = "Сверху" Then
'определяем первую строку подчиненной новой задачи под найденным родителем
XRow = IDRng.Row + 1
End If
If ImportVar = "Снизу" Then
'определяем уровень (вправо) и последнюю строку подчиненной задачи под найденным родителем
XRow = .Cells(IDRng.Row, TLevelCol - 1).End(xlDown).Row
If XRow = 1048576 Then 'если последняя ячейка листа, т.е. задач ниже нет
XRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End If
End If

End If
'добавляем новую строку в зависимости от условий выше, родитель или подчиненный
.Rows(7).Copy
.Rows(XRow).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False

'если нашли ID, переходим к существующей задаче и обновляем ее
Else
TStatus = "Обновлена существующая задача " & ID
XRow = IDRng.Row
TLevelCol = 7 + .Cells(XRow, 2).Value
End If

'заполняем поля в соответствии с отчетом (3 типа: новая / новая подчиненная / существующая обновляемая)
'если будут изменяться столбцы, то поменять нумерацию ниже, либо добавить имена и ссылаться на номера их столбцов!!! Выше см тоже!
.Cells(XRow, 1).Value = ID
.Cells(XRow, 3).Value = Cells(ARow, 4).Value 'постановщик имя
.Cells(XRow, 5).Value = Cells(ARow, 5).Value 'ответственный имя
.Cells(XRow, 6).Value = Cells(ARow, 17).Value 'категория
.Range("H" & XRow & ":L" & XRow).Value = "" 'очищаем наименование задачи по всем уровням, т.к. строка скопирована с задачей первой строки
.Cells(XRow, TLevelCol).Value = Cells(ARow, 3).Value 'наименование задачи
.Cells(XRow, 13).Value = TStatus

Continue:
Next

End With

End If

End With

End Sub