Доброго времени суток. У меня есть две таблицы на 2-х листах(поставка и инфо ) на листе "инфо" : "код товара" и его "название", на "поставках" : "номер поставки" и "код товара", надо что бы на листе "поставка" в 3 столбец происходила вставка названия товара , по его коду. В примере все понятнее Макрос такой [vba]
Код
Sub копирование_2() Dim x As Range, wsh1 As Worksheet, wsh2 As Worksheet, i As Long Application.ScreenUpdating = False Set wsh1 = Sheets("инфо"): Set wsh2 = Sheets("поставка") i = 1 For i = 2 To wsh2.Cells(Rows.Count, 2).End(xlUp).Row Set x = wsh1.Columns(1).Find(wsh2.Cells(i, 2), LookIn:=xlValues, lookat:=xlPart) If Not x Is Nothing Then wsh2.Cells(i, 3).Value = x.Offset(, 1).Value Next End Sub
[/vba] И все у меня не плохо и все работает, вот только когда на листе "инфо" около 58000 строк, а на "поставка" около 18000, все это происходит минимум за 14 минут Вопрос вот в чем, может быть можно как-то быстрее это делать, может есть другое решение, я как бы совсем зеленая с vba. Буду благодарна за помощь.
Доброго времени суток. У меня есть две таблицы на 2-х листах(поставка и инфо ) на листе "инфо" : "код товара" и его "название", на "поставках" : "номер поставки" и "код товара", надо что бы на листе "поставка" в 3 столбец происходила вставка названия товара , по его коду. В примере все понятнее Макрос такой [vba]
Код
Sub копирование_2() Dim x As Range, wsh1 As Worksheet, wsh2 As Worksheet, i As Long Application.ScreenUpdating = False Set wsh1 = Sheets("инфо"): Set wsh2 = Sheets("поставка") i = 1 For i = 2 To wsh2.Cells(Rows.Count, 2).End(xlUp).Row Set x = wsh1.Columns(1).Find(wsh2.Cells(i, 2), LookIn:=xlValues, lookat:=xlPart) If Not x Is Nothing Then wsh2.Cells(i, 3).Value = x.Offset(, 1).Value Next End Sub
[/vba] И все у меня не плохо и все работает, вот только когда на листе "инфо" около 58000 строк, а на "поставка" около 18000, все это происходит минимум за 14 минут Вопрос вот в чем, может быть можно как-то быстрее это делать, может есть другое решение, я как бы совсем зеленая с vba. Буду благодарна за помощь.eneycheva
Ну, я совсем не спец. Но как мне кажется, если даже отключить на время работы макроса перерисовку страниц и границ, поставив коды в начале и в конце - дело пойдет веселее. [vba]
Ну, я совсем не спец. Но как мне кажется, если даже отключить на время работы макроса перерисовку страниц и границ, поставив коды в начале и в конце - дело пойдет веселее. [vba]
Sub uuu() Dim a(), b(), c() Dim i& t = Timer 'удалить With Sheets("инфо") a = .Range("A2:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With With Sheets("поставка") b = .Range("A2:C" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With Set x = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a) x.Item(CStr(a(i, 1))) = a(i, 2) Next ReDim Preserve b(1 To UBound(b), 1 To 3) For i = 1 To UBound(b) If x.Exists(b(i, 2)) Then b(i, 3) = x.Item(b(i, 2)) Next With Sheets("поставка") .Cells(2, 1).Resize(UBound(b), 3) = b End With MsgBox Timer - t 'удалить End Sub
[/vba] Только проверьте )
Вариант [vba]
Код
Sub uuu() Dim a(), b(), c() Dim i& t = Timer 'удалить With Sheets("инфо") a = .Range("A2:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With With Sheets("поставка") b = .Range("A2:C" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With Set x = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a) x.Item(CStr(a(i, 1))) = a(i, 2) Next ReDim Preserve b(1 To UBound(b), 1 To 3) For i = 1 To UBound(b) If x.Exists(b(i, 2)) Then b(i, 3) = x.Item(b(i, 2)) Next With Sheets("поставка") .Cells(2, 1).Resize(UBound(b), 3) = b End With MsgBox Timer - t 'удалить End Sub