testuser написал: Получается как бы тупая уровниловка, тех кто вообще не хочет шевелить мозгами со всеми остальными
Я бы не назвал это уравниловкой, тех кто хоть немного шевелит мозгами вначале предупреждают, о том, что нужно прочитать правила и предложить изменения, чтобы модераторы могли отредактировать тему, а у тех кто ни бе ни ме, закрывают тему, собственно это нормально
Думаю, что можно, но нужно точно понимать, что именно изображать. Вы бы приложили файл с примером, для лучшего понимания задачи (как сделать такой файл описано в ПРАВИЛАХ форума)
ольга, почитайте правила форума, там очень хорошо описано как должно выглядеть название темы. Предложите новое, а наши добрые модераторы его заменят, а если вы этого не сделаете, то злые модераторы закроют тему
А я остальные листы и не смотрел. Там немного формат другой, ни как на первом листе, поэтому и не получается. Если не нужно было бы перед слешем выделять число, то было бы проще
Евгений Смирнов написал: записывается один из методов заполнения словаря ключами со значениями Emtpy
А зачем, не проще так
Код
Sub enstaralgfjh()
Dim Arr1, Arr2, i As Long, Dic1
Application.ScreenUpdating = False
Set Dic1 = CreateObject("Scripting.Dictionary")
Arr1 = ThisWorkbook.Worksheets("Лист1").UsedRange
Arr2 = ThisWorkbook.Worksheets("Лист2").UsedRange
For i = 2 To UBound(Arr2)
If Not Dic1.Exists(Arr2(i, 1)) Then Dic1.Add (Arr2(i, 1)), i
Next i
For i = 2 To UBound(Arr1)
If Dic1.Exists(Arr1(i, 1)) Then
Arr1(i, 5) = Arr2(Dic1(Arr1(i, 1)), 2)
Arr1(i, 9) = Arr2(Dic1(Arr1(i, 1)), 3)
Arr1(i, 11) = Arr2(Dic1(Arr1(i, 1)), 4)
End If
Next i
Sheets("Лист1").Cells(1, 1).Resize(UBound(Arr1), UBound(Arr1, 2)) = Arr1
End Sub
УПС, не внимательно прочитал первое сообщение, во второй таблице 500 тыс, тогда всё верно, но удалять не буду, пусть будет как вариант По скорости ТС пусть отпишется
mearkhipova, Вы бы в примере показали, что именно должно получиться (хотя бы в нескольких ячейках), а то не совсем понятно в каком виде должен быть результат