да, это решило проблему! спасибо большое!

file attached

я изменил немножко код! чтоб он делал дополнительную проверку которая мне нужна! но  почему то выходит ошибка на этой строке    
 
If Len(Trim(c(i, 2))) <> 0 And Len(Trim(c(i, 3))) = 0 Then  
 
весь код теперь выглядит так  
 
 
Sub h_locate_negatives()  
Dim a(), b(), c()  
Dim i&, temp$, s, ss$, w, flag As Boolean  
 
a = Sheets("Tabelle2").[a1].CurrentRegion.Value
With Sheets(1).[a1]
b = .CurrentRegion.Columns(1).Value  
c = .CurrentRegion.Offset(, 1).Resize(UBound(b), 2).Value  
 
With CreateObject("Scripting.Dictionary")  
.comparemode = 1  
For i = 1 To UBound(a)  
temp = Trim(a(i, 1))  
If Len(temp) Then .Item(temp) = i  
Next  
 
For i = 3 To UBound(b)  
flag = False  
temp = Trim(b(i, 1))  
If Len(Trim(c(i, 1))) = 0 Then  
s = Split(temp)  
For Each w In s  
If Not .exists(w) Then  
ss = ss & " " & w  
Else  
flag = True  
End If  
Next  
If flag Then  
If Len(ss) Then c(i, 1) = "negative": c(i, 2) = Trim(ss): ss = ""  
Else  
ss = ""  
End If  
End If  
If Len(Trim(c(i, 2))) <> 0 And Len(Trim(c(i, 3))) = 0 Then  
s = Split(temp)  
For Each w In s  
If Not .exists(w) Then  
ss = ss & " " & w  
Else  
flag = True  
End If  
Next  
If flag Then  
If Len(ss) Then c(i, 1) = "negative": c(i, 2) = Trim(ss): ss = ""  
Else  
ss = ""  
End If  
End If  
Next  
End With  
 
.CurrentRegion.Offset(, 1).Resize(UBound(b), 2).Value = c  
End With  
End Sub  
 
Спасибо за помощь

Получается это не возможно сделать ?

да, я так и делал досихпор, удалял все и заново запускал код. Хотел узнать если можно сделать овтоматически это!    
 
Получается что те строки где только в В столбе есть инфо или те которые B,C,D,E заполнены не надо трогать. а остальные можно переписать.

В файле больше инфо! думаю так будет понятней!    
 
Спасибо

Доброе утро,  
 
Вот есть вопрос, как можно сделать этот код так чтоб если я добавлю новое слово в лист DB чтоб можно было по новому использовать эго на те результаты    
- где collumn B пусто или    
- collumn B и С чтото написано но D пусто.    
а все другое как и до этого не трогать...  
 
Спасибо большое

Здравствуйте...  
 
Вот какую проблему обнаружил!    
Если не одного слово не найдено то результат копируется в следующею строку а ту на туже.    
 
Можно в приложенном файле посмотреть что происходит  
Как это можно исправить?  
 
Спасибо

Работает супер!    
 
еще раз спасибо! а тут нету системы давать очки за ответы, ну награждение? ))

Спасибо Hugo,  
 
а как можно еще добавить чтоб само id тоже копировалась? item_id из data

вот что у меня есть пока...    
 
 
Option Explicit  
 
Sub ertert()  
Dim x, y, rez(), s, i&, j&, k&, str$  
x = Range("G2:G" & Cells(Rows.Count, 1).End(xlUp).Row).Value  
With Sheets("data")  
   y = .Range("B2:I" & .Cells(Rows.Count, 1).End(xlUp).Row).Value  
End With: ReDim rez(1 To UBound(x), 1 To 4)  
With CreateObject("Scripting.Dictionary")  
   .CompareMode = 0  
   For i = 1 To UBound(y): .Item(UCase(y(i, 1))) = i: Next i  
   For i = 1 To UBound(x)  
       str = Trim(UCase(x(i, 1)))  
       If .Exists(str) Then  
           k = .Item(str): rez(i, 1) = y(k, 2): rez(i, 2) = y(k, 3): rez(i, 3) = y(k, 4): rez(i, 4) = y(k, 5)  
       Else  
           s = Split(Trim(x(i, 1)))  
           For j = 0 To UBound(s)  
               str = UCase(s(j))  
               If .Exists(str) Then  
                   k = .Item(str): rez(i, 1) = y(k, 2): rez(i, 2) = y(k, 3): rez(i, 3) = y(k, 4): rez(i, 4) = y(k, 5)  
               End If  
           Next j  
       End If  
   Next i  
End With: [b3:e3].Resize(i - 1).Value = rez()
End Sub  
 
 
Но это не работает совсем правильно, потому что не вся информация копируется да и вставляет ее не в конец а начиная с B3... !    
 
Очень нужна ваша помощь!    
Спасибо

Нужна срочная помощь!!  
 
Работаю над очень большим файлом и надо соединить информацию с 2 листа.  
Надо сравнить из листа "MainSheet" колонну G с колонной B из листа data и там где совпадает надо скопировать информацию с листа data начиная с колонны С на конец строки в MainSheet    
 
В файле есть пример что надо сделать! Зеленым цветом что надо сровнить и желтым что надо копировать.    
 
Спасибо огромное!

Спасибо за помощь

Это мое сообшение было ))

да, оба тоже работают очень правильно и хорошо!    
вот только подумал, можно ли сделать так что если не одного слово из DB не было найдено в Search term то нечего чтоб не копировалась и negative тоже не надо добавлять...  
 
Спасибо большое за помощь

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

сделал комментарии. надеюс так будет понятно

Здравствуйте,  
 
Начну с того что извинюсь за ошибки )) русский не родной язык, сам из Греции.    
Мне посоветовали этот форум и надеюсь найти тут ответ к моей проблемы.  
 
У меня два Списка, один с фразами а второй со словами.  
Я хочу узнать если можно с помошей макро кода найти из первого списка с фразами те слова которых нету во втором списке со словами и скопировать их в другую cell.    
 
в Приложение файл как пример и какой результат должен бить. Я добавил шит по имени "Defaul" и там показано как первоначальные результаты были.  
 
Спасибо за помощь