Кирилл,  можно сделать за один проход по данным, плюс еще один проход по словарю:  
 
1. Создать один словарь Dictionary из всех элементов данных, независимо ID это или PARENT столбец, потому что какой-нибудь parent может оказаться одновременно и child-ом.  
 
2. Ключ каждого элемента словаря – из текстовых значений столбцов ID, PARENT  
 
3. Значение каждого элемента – массив (1 To 4) соответственно:  
 
- ChildCount As Integer (кол-во детей - складывать по ключу из столбца ID)  
- ParentCount As Integer  (кол-во родителей  - складывать по ключу из столбца PARENT)  
- Childs As String (список не более чем из первых 2-х элементов, если больше – добавить троеточие)  
- Parents As String (аналогично списку Childs)  
 
4. Массив отчета (0 To 5) заполнить из полученного словаря только для элементов с ChildCount>1 или ParentCount>1:  
 
- ID As String (ключ Key словаря)  
- ChildCount  As Integer  (только если > 1)  
- ParentCount As Integer  (только если > 1)  
- Childs As String (что получилось в словаре)  
- Parents As String (что получилось в словаре)  
- Description As String (Например: "ERRORS: ChildCount>1, ParentCount>1")  
 
5. Босса отслеживать в цикле п.3 по пустому значению в столбце PARENT (комментарий = "root"), а если не случилось, то (считать параллельно)по максимуму ChildCount  (комментарий = "calculated").    
 
6. В первой строке отчета прописать ID босса, а в комментарии - "root" или "calculated". Если root-боссов насчиталось несколько, то указать это в комментарии как ошибку. Перед тем как формировать остальные строки отчета по п.4 удобно удалить из словаря элемент Босса, чтобы исключить проверку в цикле.  
 
Может что-то не учел, но похоже, что исходные правила можно трактовать подобным образом. По-крайней мере, можно рассмотреть это как стартовый вариант идеи.

Владимир,  
 
Сейчас вчитался, и похоже не хватает главных проверок. Или я чего-то не разглядел в описании? :-)  
 
Мои критерии - лишь описание дополнительных ситуаций.    
 
Самое главное - это проверка на то, имеем ли мы связанный ациклический граф (т.е. дерево). Тут нужно проверять не только на наличие сирот и наличие более одного родителя, но и на ситуации когда...    
 
отец - сын своему сыну  
1|2  
2|1  
 
дед - сын своему внуку  
1|2  
2|3  
3|1  
 
сын - отец сам себе  
1|1  
 
наверняка есть еще другие возможные ошибки.  
 
Убежден, что существует готовый алгоритм подобной проверки, но не могу найти.  
Подозреваю, что:  
- без рекурсии не обойтись  
- придется просто тупо строить дерево (тогда вопрос будет уже как)  
 
Спасибо за участие.

Протянув формулу до конца, наблюдаем, что в графе одна ошибка (в строке 261)  
1250 1250 Loop present  
 
Исправив эту ошибку (меняем 1250 - 1250 на 1250 - 28861), обнаруживаем, что дерево построено корректно - все пути ведут наверх, к 28861  
 
Или в моём алгоритме есть ошибка?

EducatedFool,  
 
Спасибо большое. Похоже, это оно. Единственно, наверное придется цикл все же сделать конечным, а то если например поставить в ячейке [B295] вставить 420, то все повисает надолго :-) Но это уже мелочи.

Пока как-то так, но еще не закончил:  
 
Function Top(ByVal Child, ByVal Parent, ByRef ra As Range)  
   Dim res As Range  
   Dim NewParent  
   Dim dups As Collection  
   Set dups = New Collection  
     
   NewParent = Parent  
   On Error GoTo errHandler  
   Do  
       Set res = ra.Find(NewParent, , , xlWhole)  
       If Not res Is Nothing Then  
           dups.Add NewParent, NewParent  
           NewParent = res.Next  
           If NewParent = "" Then Top = res:  Exit Function  
           If NewParent = res Then Top = "Child=Parent": Exit Function  
       Else  
           Top = IIf(NewParent = "", Child, NewParent): Exit Function  
       End If  
         
   Loop Until res Is Nothing  
   Exit Function  
errHandler:  
   Top = "Loop"  
End Function  
 
Sub CheckTree()  
   Dim rng As Range  
   Dim arr As Variant  
   Dim i As Long  
   Dim wsReport As Worksheet  
     
   Application.ScreenUpdating = False  
     
   On Error Resume Next  
   Application.DisplayAlerts = False  
   Worksheets("Report").Delete  
   Application.DisplayAlerts = True  
   On Error GoTo 0  
     
   Worksheets(1).Copy after:=Worksheets(1)  
     
   With ActiveSheet  
       .Name = "Report"  
       Set rng = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))  
     
       ReDim arr(1 To rng.Count, 1 To 1) As String  
         
       For i = 1 To UBound(arr)  
           If rng(i, 1) <> "" Then arr(i, 1) = Top(rng(i, 1), rng(i, 2), rng)  
       Next i  
         
       With rng.Offset(, 2)  
           .Value = arr  
       End With  
         
       'check for duplicated values in col1  
       'check for empty values in col1  
       'check for empty values in col2 >1  
       'color code values in col3  
   End With  
   Application.ScreenUpdating = True  
End Sub  
   
 
1) Пришлось добавить проверку на повтор NewParent, чтобы избежать бесконечного цикла в ситуации описанной в моем сообщении от 02.07.2010, 03:17  
   
2) Мне показалось, что строка  
 
If NewParent = Child Then God = "Loop present": Exit Function  
 
дублирует строку  
 
If NewParent = res Then God = res & " child=parent": Exit Function  
 
т.ч. я удалил первую, но может, я что-то не разглядел.  
 
Заранее спасибо за комментарии.

"таб", соответственно, это первые два столбца

слэн,  
 
Большое спасибо. Очень визуально.    
Я слегка модифицировал формулу:  
 
=ЕСЛИ(И(B2<>"";B2<>A2);Т(ВПР(B2;$A$2:$B$391;2;0));"")  
 
Это в принципе вариант, но в моем случае, должностей может быть до 10.000, т.ч. визуальный анализ затруднен, да и формулы могут начать тормозить. Также усложняется проверка на то, все ли оканчиваются, на одной и той же должности.

{quote}{login=KL}{date=03.07.2010 02:01}{thema=}{post}слэн,  
 
Большое спасибо. Очень визуально.    
Я слегка модифицировал формулу:  
 
=ЕСЛИ(И(B2<>"";B2<>A2);Т(ВПР(B2;$A$2:$B$391;2;0));"")  
 
Это в принципе вариант, но в моем случае, должностей может быть до 10.000, т.ч. визуальный анализ затруднен, да и формулы могут начать тормозить. Также усложняется проверка на то, все ли оканчиваются, на одной и той же должности.{/post}{/quote}  
 
так на этом же алгоритм и построить.  чуть-чуть модернизировав.. щас

Слэн,  
 
Спасибо, попробую как выдастся свободная минутка.    
 
Правда вижу, что использовали функцию MAX, а с ней две проблемы:  
 
1) ID руководителя не обязательно больше или меньше, чем у подчиненного.Единственное требование к ID - уникальность  
 
2) значения все текстовые  
 
Спасибо еще раз.

Слэн,  
 
Спасибо еще раз. Я как раз переводил в Dictionary :-)  
 
Не очень понимаю смысл строки:  
 
ar(pr(i, 1)) = CLng(pr(i, 2))  
 
ведь pr(i, 1) вернет стринг, да еще и с кодом сотрудника, а это вернейшая ошибка "Subscript out of range", если учитывать, что:  
 
m = WorksheetFunction.Max(Range("a2").Resize(n)) -> всегда будет равно 0  
 
а значит:  
 
ReDim ar(0 To m) -> всегда будет равно ar(0 To 0)  
 
Или я не вижу очевидного?

да, я забыл, что вручную перевел коды в числа.  
 
текстовый формат - это ничего. можно воспользоваться формулой макс(диапазон+0)  
 
тогда в принципе не обязательно преводить в long?  но, наверное все таки стоит.  
 
щас поэксперементирую.

если коды нецифровые, тоже можно обойти  
 
допустим есть два массива id  и pr  с нечисловыми кодами..  
 
тогда ar можно получить так:  
 
for i=1 to n  
ar(i)=match(pr(i),id)  
next  
 
немножко дольше инициализация, но потом также быстро..

ну да. В общем то это просто сведение задачи к уже решенной :)  
 
интересно, можно ли обойтись без match..