Sub uuu()
     Dim a(), b()
     Dim i&, ii&, j&, jj&, rw&
     t = Timer
     Application.ScreenUpdating = False 'отключаем обновление экрана
     Sheets("in").UsedRange.ClearContents 'чистим диапазон на листе "in"
     For i = 0 To 7000 'почему именно 7000 я не знаю
         With Sheets("Подстановка") 'работаем с листом "Подстановка"
             .Range("B4").Delete Shift:=xlToLeft 'удаляем ячейку со здвигом
             .Rows(4).Copy .Range("A3") 'копируем 4ю строку на 3ю
             a = .Range("B6").CurrentRegion.Value 'берём в массив диапазон B6: и до краёв непрерывной таблицы
         End With
         ReDim b(1 To 40, 1 To 90) 'перезаписываем массив b
         For ii = 1 To UBound(b) 'идём по строкам массива b от 1й до последней
             j = 0 'счётчик колонок для записи в массив b
             For jj = 1 To UBound(b, 2) 'проходим по колонкам массива b
                 'вычисляем есть ли совпадения номера 1-90 (номера колонок массива b)
                 'с циферками в массиве а
                 If считанем(a, ii, jj) = False Then 'если результат "ложь" то
                     j = j + 1 'увеличиваем счётчик колонок
                     b(ii, j) = jj 'пишем в массив b в крайнюю слева ячейку номер колонки
                 End If
             Next
         Next
         rw = i * 72 + 2 'ститаем номер строки для выгрузки массива b
         With Sheets("in") 'работаем с листом "in"
             .Cells(rw, 3).Resize(UBound(b), UBound(b, 2)) = b 'выгружаем массив на лист
         End With
     Next
     Application.ScreenUpdating = True 'включаем обновление экрана
     MsgBox Timer - t
End Sub

Function считанем(a(), ii&, jj&) As Boolean
     Dim j& 'счётчик колонок массива a()
     For j = 1 To UBound(a, 2) 'проходим по всем элементам нужной строки
         If a(ii, j) = jj Then 'если есть совпадение то
             считанем = True 'функция принимает значение "истина"
             Exit For 'выходим из цикла
         End If
     Next
End Function