Есть у меня один шаблон кода для таких задач.  
Обычно хвататет изменить пару строк...  
 
Option Explicit  
 
'Макросом -  
'1.два диапазона в два массива  
'2.создание массива для результатов  
'3.один перебор 300 значений массива в словарь  
'4.100 000 проверок массива на наличие в словаре и заполнение данными массива результата  
'5.выгрузка результатов (тут нет предварительной очистки диапазона)  
 
Sub compare()  
   Dim a(), b(), c(), iLastrow&, i&, ii&, x As Byte  
 
   '1.  
   With Sheets(1)  
       iLastrow = .Cells(Rows.Count, 7).End(xlUp).Row  
       a = Range(.[g1], .Range("G" & iLastrow)).Value
   End With  
 
   With Sheets(2)  
       iLastrow = .Cells(Rows.Count, 2).End(xlUp).Row  
       b = Range(.[b1], .Range("Q" & iLastrow)).Value
   End With  
 
   '2.  
   ReDim c(1 To UBound(a), 1 To 15)  
 
   With CreateObject("Scripting.Dictionary")  
 
       '3.  
       For i = 1 To UBound(b)  
           .Item(b(i, 1)) = i  
       Next  
 
       '4.  
       For i = 1 To UBound(a)  
           If .exists(a(i, 1)) Then  
               ii = .Item(a(i, 1))  
               For x = 2 To 16: c(i, x - 1) = b(ii, x): Next  
           End If  
       Next  
   End With  
 
   '5.  
   With Sheets(1)  
       .[AF1].Resize(i - 1, 15) = c
   End With  
 
End Sub  
 
 
Можно было бы и тот код наладить - но проще свой :)

А зачем? Оно ведь рядом :)  
Как -    
расширить итоговоый массив:  
ReDim c(1 To UBound(a), 1 To 16)  
 
заполнять его так:  
For x = 1 To 16: c(i, x) = b(ii, x): Next  
 
И выгружать соответственно пошире:  
.[AF1].Resize(i - 1, 16) = c
 
Не проверял :)