Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/вставка данных в ячейки по условию - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » вставка данных в ячейки по условию (Макросы Sub)
вставка данных в ячейки по условию
eneycheva Дата: Четверг, 06.03.2014, 07:49 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Доброго времени суток. У меня есть две таблицы на 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.
Буду благодарна за помощь.
К сообщению приложен файл: 8653137.xlsm (17.2 Kb)
 
Ответить
СообщениеДоброго времени суток. У меня есть две таблицы на 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
Дата добавления - 06.03.2014 в 07:49
igrtsk Дата: Четверг, 06.03.2014, 11:56 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 314
Репутация: 50 ±
Замечаний: 0% ±

Excel 2016
Ну, я совсем не спец.
Но как мне кажется, если даже отключить на время работы макроса перерисовку страниц и границ, поставив коды в начале и в конце - дело пойдет веселее.
[vba]
Код

Application.ScreenUpdating = False 'отключение перерисовки окна
ActiveSheet.DisplayPageBreaks = False  'отключение перерисовки границ страниц

Application.ScreenUpdating = True 'включение перерисовки окна
ActiveSheet.DisplayPageBreaks = True  'включение перерисовки границ страниц
[/vba]

Инструктор по применению лосей в кавалерийских частях РККА
 
Ответить
СообщениеНу, я совсем не спец.
Но как мне кажется, если даже отключить на время работы макроса перерисовку страниц и границ, поставив коды в начале и в конце - дело пойдет веселее.
[vba]
Код

Application.ScreenUpdating = False 'отключение перерисовки окна
ActiveSheet.DisplayPageBreaks = False  'отключение перерисовки границ страниц

Application.ScreenUpdating = True 'включение перерисовки окна
ActiveSheet.DisplayPageBreaks = True  'включение перерисовки границ страниц
[/vba]
Автор - igrtsk
Дата добавления - 06.03.2014 в 11:56
eneycheva Дата: Четверг, 06.03.2014, 13:13 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
igrtsk, спасибо это сэкономило пару минут :)
в идеале, хотелось бы минуты 3-5, но видимо не судьба.
 
Ответить
Сообщениеigrtsk, спасибо это сэкономило пару минут :)
в идеале, хотелось бы минуты 3-5, но видимо не судьба.
Автор - eneycheva
Дата добавления - 06.03.2014 в 13:13
wild_pig Дата: Четверг, 06.03.2014, 15:26 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 518
Репутация: 97 ±
Замечаний: 0% ±

2003, 2013
Вариант
[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]
Только проверьте )


Сообщение отредактировал wild_pig - Четверг, 06.03.2014, 15:34
 
Ответить
СообщениеВариант
[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]
Только проверьте )
Автор - wild_pig
Дата добавления - 06.03.2014 в 15:26
eneycheva Дата: Четверг, 06.03.2014, 18:40 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
wild_pig, огромное вам спасибо!!! Все работает.
Буду лучше учить мат часть :D
 
Ответить
Сообщениеwild_pig, огромное вам спасибо!!! Все работает.
Буду лучше учить мат часть :D
Автор - eneycheva
Дата добавления - 06.03.2014 в 18:40
Мир MS Excel » Вопросы и решения » Вопросы по VBA » вставка данных в ячейки по условию (Макросы Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!