Друзья, приходится обратиться сегодня уже второй раз за помощью. Имеется файл в котором два листа, второй лист "Предоплата" это небольшая часть листа БАЗА Сам файл большой и обычный цикл выполняется долго, имеется такой вот цикл:
[vba]
Код
Private Sub CommandButton1_Click() Dim f As String Application.ScreenUpdating = False Application.Calculation = xlManual
For p = 2 To lAntR f = Sheets("Предоплата").Cells(p, 3).Value For I = lAntRB To 2 Step -1 s = Sheets("БАЗА").Cells(I, 7).Value If f = s And Sheets("БАЗА").Cells(I, 8).Value <> " " Then Sheets("Предоплата").Cells(p, 2).Value = Sheets("БАЗА").Cells(I, 6).Value 'клиент Sheets("Предоплата").Cells(p, 4).Value = Sheets("БАЗА").Cells(I, 8).Value 'РН Sheets("Предоплата").Cells(p, 5).Value = Sheets("БАЗА").Cells(I, 9).Value 'Дата окончания Sheets("Предоплата").Cells(p, 8).Value = Sheets("БАЗА").Cells(I, 12).Value 'Сумма Sheets("Предоплата").Cells(p, 12).Value = Sheets("БАЗА").Cells(I, 16).Value 'прим Sheets("Предоплата").Cells(p, 13).Value = Sheets("БАЗА").Cells(I, 17).Value 'прим1 Exit For End If Next I Next p Application.Calculation = xlAutomatic Application.ScreenUpdating = False End Sub
[/vba]
На основном файле выполняется 20-30 минут Прошу помощи в его адаптации через словарь или массивы. Поиск происходит по столбцу СФ
Если простыми словами, то ищет поочередно на листе Предоплаты сверху вниз СФ и подставляет определенные данные с листа база, но с конца, при условии что на листе база у данной СФ есть РН, если РН не заполнено, то пропускаем.
Заранее спасибо.
Друзья, приходится обратиться сегодня уже второй раз за помощью. Имеется файл в котором два листа, второй лист "Предоплата" это небольшая часть листа БАЗА Сам файл большой и обычный цикл выполняется долго, имеется такой вот цикл:
[vba]
Код
Private Sub CommandButton1_Click() Dim f As String Application.ScreenUpdating = False Application.Calculation = xlManual
For p = 2 To lAntR f = Sheets("Предоплата").Cells(p, 3).Value For I = lAntRB To 2 Step -1 s = Sheets("БАЗА").Cells(I, 7).Value If f = s And Sheets("БАЗА").Cells(I, 8).Value <> " " Then Sheets("Предоплата").Cells(p, 2).Value = Sheets("БАЗА").Cells(I, 6).Value 'клиент Sheets("Предоплата").Cells(p, 4).Value = Sheets("БАЗА").Cells(I, 8).Value 'РН Sheets("Предоплата").Cells(p, 5).Value = Sheets("БАЗА").Cells(I, 9).Value 'Дата окончания Sheets("Предоплата").Cells(p, 8).Value = Sheets("БАЗА").Cells(I, 12).Value 'Сумма Sheets("Предоплата").Cells(p, 12).Value = Sheets("БАЗА").Cells(I, 16).Value 'прим Sheets("Предоплата").Cells(p, 13).Value = Sheets("БАЗА").Cells(I, 17).Value 'прим1 Exit For End If Next I Next p Application.Calculation = xlAutomatic Application.ScreenUpdating = False End Sub
[/vba]
На основном файле выполняется 20-30 минут Прошу помощи в его адаптации через словарь или массивы. Поиск происходит по столбцу СФ
Если простыми словами, то ищет поочередно на листе Предоплаты сверху вниз СФ и подставляет определенные данные с листа база, но с конца, при условии что на листе база у данной СФ есть РН, если РН не заполнено, то пропускаем.
Sub Мяв() Dim arr, arr1 Dim i&, ii& arr = Sheets("БАЗА").Range("A1").CurrentRegion.Value arr1 = Sheets("Предоплата").Range("A1").CurrentRegion.Value For i = UBound(arr1) To 2 Step -1 For ii = 1 To UBound(arr) If arr1(i, 3) = arr(ii, 7) Then If Len(arr(ii, 8)) Then ' правка arr1(i, 8) = arr(ii, 12) arr1(i, 12) = arr(ii, 16) arr1(i, 13) = arr(ii, 17) arr1(i, 2) = arr(ii, 6) arr1(i, 4) = arr(ii, 8) arr1(i, 5) = arr(ii, 9) End If Exit For End If Next Next Sheets("Предоплата").Range("A1").CurrentRegion = arr1 End Sub
[/vba]
[vba]
Код
Sub Мяв() Dim arr, arr1 Dim i&, ii& arr = Sheets("БАЗА").Range("A1").CurrentRegion.Value arr1 = Sheets("Предоплата").Range("A1").CurrentRegion.Value For i = UBound(arr1) To 2 Step -1 For ii = 1 To UBound(arr) If arr1(i, 3) = arr(ii, 7) Then If Len(arr(ii, 8)) Then ' правка arr1(i, 8) = arr(ii, 12) arr1(i, 12) = arr(ii, 16) arr1(i, 13) = arr(ii, 17) arr1(i, 2) = arr(ii, 6) arr1(i, 4) = arr(ii, 8) arr1(i, 5) = arr(ii, 9) End If Exit For End If Next Next Sheets("Предоплата").Range("A1").CurrentRegion = arr1 End Sub
Private Sub CommandButton1_Click() Dim arrPred(), arrBase(), dicBase As Object Dim lLastRow As Long Dim i As Long, r As Long Application.ScreenUpdating = False Application.Calculation = xlManual
lLastRow = Sheets("Предоплата").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row arrPred() = Sheets("Предоплата").Range("A2:M" & lLastRow).Value lLastRow = Sheets("БАЗА").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row arrBase() = Sheets("БАЗА").Range("A1:Q" & lLastRow).Value Set dicBase = CreateObject("Scripting.Dictionary"): dicBase.CompareMode = 1 For i = 2 To UBound(arrBase) If CStr(arrBase(i, 8)) <> " " Then dicBase.Add CStr(arrBase(i, 7)), i End If Next
For i = 1 To UBound(arrPred) If dicBase.Exists(CStr(arrPred(i, 3))) = False Then GoTo metka End If r = dicBase.Item(CStr(arrPred(i, 3))) arrPred(i, 2) = arrBase(r, 6) 'клиент arrPred(i, 4) = arrBase(r, 8) 'РН arrPred(i, 5) = arrBase(r, 9) 'Дата окончания arrPred(i, 8) = arrBase(r, 12) 'Сумма arrPred(i, 12) = arrBase(r, 16) 'прим arrPred(i, 13) = arrBase(r, 17) 'прим1 metka: Next i Sheets("Предоплата").Range("A2").Resize(UBound(arrPred), UBound(arrPred, 2)).Value = arrPred() Application.Calculation = xlAutomatic Application.ScreenUpdating = False End Sub
[/vba]
[vba]
Код
Private Sub CommandButton1_Click() Dim arrPred(), arrBase(), dicBase As Object Dim lLastRow As Long Dim i As Long, r As Long Application.ScreenUpdating = False Application.Calculation = xlManual
lLastRow = Sheets("Предоплата").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row arrPred() = Sheets("Предоплата").Range("A2:M" & lLastRow).Value lLastRow = Sheets("БАЗА").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row arrBase() = Sheets("БАЗА").Range("A1:Q" & lLastRow).Value Set dicBase = CreateObject("Scripting.Dictionary"): dicBase.CompareMode = 1 For i = 2 To UBound(arrBase) If CStr(arrBase(i, 8)) <> " " Then dicBase.Add CStr(arrBase(i, 7)), i End If Next
For i = 1 To UBound(arrPred) If dicBase.Exists(CStr(arrPred(i, 3))) = False Then GoTo metka End If r = dicBase.Item(CStr(arrPred(i, 3))) arrPred(i, 2) = arrBase(r, 6) 'клиент arrPred(i, 4) = arrBase(r, 8) 'РН arrPred(i, 5) = arrBase(r, 9) 'Дата окончания arrPred(i, 8) = arrBase(r, 12) 'Сумма arrPred(i, 12) = arrBase(r, 16) 'прим arrPred(i, 13) = arrBase(r, 17) 'прим1 metka: Next i Sheets("Предоплата").Range("A2").Resize(UBound(arrPred), UBound(arrPred, 2)).Value = arrPred() Application.Calculation = xlAutomatic Application.ScreenUpdating = False End Sub
alex77755, я специально все так сделал. может быть использовать ваши замечания для ускорения макроса. я сделал,чтобы было удобно работать с кодом.
alex77755, я специально все так сделал. может быть использовать ваши замечания для ускорения макроса. я сделал,чтобы было удобно работать с кодом.Karataev
Коллеги, спасибо за помощь. Нету пока времени потестить более тщательно, но на скорую руку проверив на живом файле, макрос предложенный Karataev срабатывает в разы быстрее и отрабатывает правильно. но при исправлении alexx77755 в посте 5, если не исправить это, то почему то стопорит и выдает ошибку. Андрей, твой макрос я еще покручу поверчу но уже вижу что предложенный тобой вариант не проверяет наличие РН на листе БАЗА столбец H (восьмой) и отрабатывает намного медленнее. Но однозначно с этим всем уже добью до конца. Но насколько понял, то со словарем все же намного шустрее. Всем огромное спасибо
Коллеги, спасибо за помощь. Нету пока времени потестить более тщательно, но на скорую руку проверив на живом файле, макрос предложенный Karataev срабатывает в разы быстрее и отрабатывает правильно. но при исправлении alexx77755 в посте 5, если не исправить это, то почему то стопорит и выдает ошибку. Андрей, твой макрос я еще покручу поверчу но уже вижу что предложенный тобой вариант не проверяет наличие РН на листе БАЗА столбец H (восьмой) и отрабатывает намного медленнее. Но однозначно с этим всем уже добью до конца. Но насколько понял, то со словарем все же намного шустрее. Всем огромное спасибоDJ_Marker_MC
Все равно немного не так))) ты не в том цикле Step -1 сделал и проверку на РН тоже не так подправил))) Вообщем вот так итоговый код твой выглядит и правильно отрабатывает:
[vba]
Код
Private Sub CommandButton1_Click() Dim arr, arr1 Dim i&, ii& arr = Sheets("БАЗА").Range("A1").CurrentRegion.Value arr1 = Sheets("Предоплата").Range("A1").CurrentRegion.Value For i = 2 To UBound(arr1) For ii = UBound(arr) To 2 Step -1 If arr1(i, 3) = arr(ii, 7) Then If Len(arr(ii, 8)) <> 1 Then ' правка arr1(i, 8) = arr(ii, 12) arr1(i, 12) = arr(ii, 16) arr1(i, 13) = arr(ii, 17) arr1(i, 2) = arr(ii, 6) arr1(i, 4) = arr(ii, 8) arr1(i, 5) = arr(ii, 9) End If Exit For End If Next Next Sheets("Предоплата").Range("A1").CurrentRegion = arr1 End Sub
[/vba]
Все равно немного не так))) ты не в том цикле Step -1 сделал и проверку на РН тоже не так подправил))) Вообщем вот так итоговый код твой выглядит и правильно отрабатывает:
[vba]
Код
Private Sub CommandButton1_Click() Dim arr, arr1 Dim i&, ii& arr = Sheets("БАЗА").Range("A1").CurrentRegion.Value arr1 = Sheets("Предоплата").Range("A1").CurrentRegion.Value For i = 2 To UBound(arr1) For ii = UBound(arr) To 2 Step -1 If arr1(i, 3) = arr(ii, 7) Then If Len(arr(ii, 8)) <> 1 Then ' правка arr1(i, 8) = arr(ii, 12) arr1(i, 12) = arr(ii, 16) arr1(i, 13) = arr(ii, 17) arr1(i, 2) = arr(ii, 6) arr1(i, 4) = arr(ii, 8) arr1(i, 5) = arr(ii, 9) End If Exit For End If Next Next Sheets("Предоплата").Range("A1").CurrentRegion = arr1 End Sub
Т.к. база всегда больше предоплаты - может быть быстрее будет делать наоборот: загнать в словарь индексы предоплаты, затем идти проверкой по базе, попутно считая не пора ли проверку прекращать. А идти по базе можно и снизу вверх - если нужные скорее всего внизу.
Т.к. база всегда больше предоплаты - может быть быстрее будет делать наоборот: загнать в словарь индексы предоплаты, затем идти проверкой по базе, попутно считая не пора ли проверку прекращать. А идти по базе можно и снизу вверх - если нужные скорее всего внизу.Hugo
Если говорить о скорострельности, в макросе Karataev, есть несколько строк, смысл которых в контексте макроса - замедлить его работу. Это отключение/ включение обновления экрана и пересчета, а также многократное преобразование текста в текст [vba]
Код
CStr(arrBase(i, 7)
[/vba]
И очень странное условие проверки [vba]
Код
Cells(I, 8).Value <> " " оно же CStr(arrBase(i, 8)) <> " "
[/vba]
данных нет только в случае, если в ячейке пробел
Если говорить о скорострельности, в макросе Karataev, есть несколько строк, смысл которых в контексте макроса - замедлить его работу. Это отключение/ включение обновления экрана и пересчета, а также многократное преобразование текста в текст [vba]
Код
CStr(arrBase(i, 7)
[/vba]
И очень странное условие проверки [vba]
Код
Cells(I, 8).Value <> " " оно же CStr(arrBase(i, 8)) <> " "
[/vba]
данных нет только в случае, если в ячейке пробел RAN
То что в макросе Karataev нужно покопаться, это я понимаю, но в тоже время только что провел замер по времени: Твое предложение сработало за 17,6сек, у Karataev за 9,3сек.
Параллельно пока писал начало сообщения, успел убрать в коде CStr, макрос без этого отработал за 9,25 (так что видимо не очень влияет, но и правильно замечено походу и не нужно)
Тут мой косяк, забыл что 1с выгружает не пустоту, а 1 пробел, хотя в своем изначальном коде так и ищу " "
То что в макросе Karataev нужно покопаться, это я понимаю, но в тоже время только что провел замер по времени: Твое предложение сработало за 17,6сек, у Karataev за 9,3сек.
Параллельно пока писал начало сообщения, успел убрать в коде CStr, макрос без этого отработал за 9,25 (так что видимо не очень влияет, но и правильно замечено походу и не нужно)
Если брать нужно последний, то со словарём так и нужно делать, как я описал - предоплаты в словарь, затем по базе вверх, как нашли - копируем и выкидываем из словаря. Как набрали количество - финиш, далее базу шерстить смысла нет, незачем время тратить.
Если брать нужно последний, то со словарём так и нужно делать, как я описал - предоплаты в словарь, затем по базе вверх, как нашли - копируем и выкидываем из словаря. Как набрали количество - финиш, далее базу шерстить смысла нет, незачем время тратить.Hugo
RAN, все верно, при такой записи она как раз и вылетела. но если учесть предложение alex и записать эту строчку вот так [vba]
Код
dicBase(arrBase(i, 7)) = i
[/vba] То все хорошо.
Hugo, а разве в макросе Karataev он не именно это делает? Вообщем пока что код Karataev принимает с учетом все правок такой вид: [vba]
Код
Private Sub CommandButton2_Click() Dim arrPred(), arrBase(), dicBase As Object Dim lLastRow As Long Dim i As Long, r As Long Application.ScreenUpdating = False Application.Calculation = xlManual t = Timer
Set dicBase = CreateObject("Scripting.Dictionary"): dicBase.CompareMode = 1 For i = 2 To UBound(arrBase) If arrBase(i, 8) <> " " Then dicBase(arrBase(i, 7)) = i End If Next
For i = 1 To UBound(arrPred) If dicBase.Exists(arrPred(i, 3)) Then r = dicBase(arrPred(i, 3)) arrPred(i, 2) = arrBase(r, 6) 'клиент arrPred(i, 4) = arrBase(r, 8) 'РН arrPred(i, 5) = arrBase(r, 9) 'Дата окончания arrPred(i, 8) = arrBase(r, 12) 'Сумма arrPred(i, 12) = arrBase(r, 16) 'прим arrPred(i, 13) = arrBase(r, 17) 'прим1 End If Next i
MsgBox "Время выполнения" & Timer - t & " сек.", vbInformation End Sub
[/vba]
RAN, все верно, при такой записи она как раз и вылетела. но если учесть предложение alex и записать эту строчку вот так [vba]
Код
dicBase(arrBase(i, 7)) = i
[/vba] То все хорошо.
Hugo, а разве в макросе Karataev он не именно это делает? Вообщем пока что код Karataev принимает с учетом все правок такой вид: [vba]
Код
Private Sub CommandButton2_Click() Dim arrPred(), arrBase(), dicBase As Object Dim lLastRow As Long Dim i As Long, r As Long Application.ScreenUpdating = False Application.Calculation = xlManual t = Timer
Set dicBase = CreateObject("Scripting.Dictionary"): dicBase.CompareMode = 1 For i = 2 To UBound(arrBase) If arrBase(i, 8) <> " " Then dicBase(arrBase(i, 7)) = i End If Next
For i = 1 To UBound(arrPred) If dicBase.Exists(arrPred(i, 3)) Then r = dicBase(arrPred(i, 3)) arrPred(i, 2) = arrBase(r, 6) 'клиент arrPred(i, 4) = arrBase(r, 8) 'РН arrPred(i, 5) = arrBase(r, 9) 'Дата окончания arrPred(i, 8) = arrBase(r, 12) 'Сумма arrPred(i, 12) = arrBase(r, 16) 'прим arrPred(i, 13) = arrBase(r, 17) 'прим1 End If Next i
[/vba] Ты же не с ячейками работаешь, и кучу книг не открываешь. В массив забрал, обработал, выгрузил. А уж 1 раз экран по любому обновиться, да и файл пересчитается при нужде.
[/vba] Ты же не с ячейками работаешь, и кучу книг не открываешь. В массив забрал, обработал, выгрузил. А уж 1 раз экран по любому обновиться, да и файл пересчитается при нужде.RAN
Hugo, а разве в макросе Karataev он не именно это делает?
Что именно это? В этом макросе все диапазоны просматриваются сверху вниз, и там в словаре запоминается позиция данных (всех, и ненужных тоже) в базе, затем данные извлекаются в предоплату.
Hugo, а разве в макросе Karataev он не именно это делает?
Что именно это? В этом макросе все диапазоны просматриваются сверху вниз, и там в словаре запоминается позиция данных (всех, и ненужных тоже) в базе, затем данные извлекаются в предоплату.Hugo
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
