Hugo, понял, прошагал еще раз по макросу по F8 и понял о чем вы говорите, но мои скудные знания о словарях и массивах к сожалению не позволят без помощи реализовать то что Вы предлагаете, хотя реально понимаю об ускорении в разы...
Hugo, понял, прошагал еще раз по макросу по F8 и понял о чем вы говорите, но мои скудные знания о словарях и массивах к сожалению не позволят без помощи реализовать то что Вы предлагаете, хотя реально понимаю об ускорении в разы...DJ_Marker_MC
Sub МявМяв() Dim arr, arr1 Dim i&, ii& arr = Sheets("БАЗА").Range("A1").CurrentRegion.Value arr1 = Sheets("Предоплата").Range("A1").CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 2 To UBound(arr1) .Item(arr1(i, 3)) = i Next For i = UBound(arr) To 2 Step -1 If .exists(arr(i, 7)) Then If Len(arr(i, 8)) <> 1 Then ii = .Item(arr(i, 7)) arr1(ii, 8) = arr(i, 12) arr1(ii, 12) = arr(i, 16) arr1(ii, 13) = arr(i, 17) arr1(ii, 2) = arr(i, 6) arr1(ii, 4) = arr(i, 8) arr1(ii, 5) = arr(i, 9) End If .Remove (arr(i, 7)) End If If .Count Then Else Exit For Next End With Sheets("Предоплата").Range("A1").CurrentRegion = arr1 End Sub
Sub МявМяв() Dim arr, arr1 Dim i&, ii& arr = Sheets("БАЗА").Range("A1").CurrentRegion.Value arr1 = Sheets("Предоплата").Range("A1").CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 2 To UBound(arr1) .Item(arr1(i, 3)) = i Next For i = UBound(arr) To 2 Step -1 If .exists(arr(i, 7)) Then If Len(arr(i, 8)) <> 1 Then ii = .Item(arr(i, 7)) arr1(ii, 8) = arr(i, 12) arr1(ii, 12) = arr(i, 16) arr1(ii, 13) = arr(i, 17) arr1(ii, 2) = arr(i, 6) arr1(ii, 4) = arr(i, 8) arr1(ii, 5) = arr(i, 9) End If .Remove (arr(i, 7)) End If If .Count Then Else Exit For Next End With Sheets("Предоплата").Range("A1").CurrentRegion = arr1 End Sub
может немного не в тему, но все-таки предложу вариант с Power Query, авось где-нить пригодится. Данные для запроса берутся из двух именованных диапазонов.
может немного не в тему, но все-таки предложу вариант с Power Query, авось где-нить пригодится. Данные для запроса берутся из двух именованных диапазонов.krosav4ig
не обратил внимание,что у автора снизу вверх было движение. изменил в двух местах:1)решил брать со второй строки в массив arrBase,чтобы путаницы не было:т.к. в одном месте с первой строки было, а в другом- со второй;2)изменил,чтобы в словарь записывались только последние данные. [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("A2:Q" & lLastRow).Value Set dicBase = CreateObject("Scripting.Dictionary"): dicBase.CompareMode = 1 For i = UBound(arrBase) To 1 Step -1 If CStr(arrBase(i, 8)) <> " " Then If dicBase.Exists(CStr(arrBase(i, 7))) = False Then dicBase.Add CStr(arrBase(i, 7)), i End If 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] CStr -используется от всяких непредвиденных ситуаций. например, если сравниваемые данные могут быть двух видов: в виде текста и в виде числа. текст и число не сравниваются.
не обратил внимание,что у автора снизу вверх было движение. изменил в двух местах:1)решил брать со второй строки в массив arrBase,чтобы путаницы не было:т.к. в одном месте с первой строки было, а в другом- со второй;2)изменил,чтобы в словарь записывались только последние данные. [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("A2:Q" & lLastRow).Value Set dicBase = CreateObject("Scripting.Dictionary"): dicBase.CompareMode = 1 For i = UBound(arrBase) To 1 Step -1 If CStr(arrBase(i, 8)) <> " " Then If dicBase.Exists(CStr(arrBase(i, 7))) = False Then dicBase.Add CStr(arrBase(i, 7)), i End If 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] CStr -используется от всяких непредвиденных ситуаций. например, если сравниваемые данные могут быть двух видов: в виде текста и в виде числа. текст и число не сравниваются.Karataev
RAN, нут, так все правильно))) если СФ с листа предоплата равно СФ с листа БАЗА и у проверяемой на листе БАЗА СФ есть РН то берем данные с этой строки и переносим в эту же СФ на лист предоплата. Если СФ совпадают, а РН на листе БАЗА отсутствует, то шагаем выше по листу База в поисках такого же СФ у которого есть РН)))
И кстати тест на скорость показал что этот макрос самый крутой)))) - 0,5 - 0,8 сек.
RAN, нут, так все правильно))) если СФ с листа предоплата равно СФ с листа БАЗА и у проверяемой на листе БАЗА СФ есть РН то берем данные с этой строки и переносим в эту же СФ на лист предоплата. Если СФ совпадают, а РН на листе БАЗА отсутствует, то шагаем выше по листу База в поисках такого же СФ у которого есть РН)))
И кстати тест на скорость показал что этот макрос самый крутой)))) - 0,5 - 0,8 сек.DJ_Marker_MC
но при исправлении alexx77755 в посте 5, если не исправить это, то почему то стопорит и выдает ошибку.
Возможно где-то что-то не так. Вот что я имел в виду полный код
[vba]
Код
Private Sub Comma() Dim arrPred(), arrBase(), dicBase As Object Dim lLastRow As Long Dim i As Long, r As Long Application.ScreenUpdating = False Application.Calculation = xlManual
но при исправлении alexx77755 в посте 5, если не исправить это, то почему то стопорит и выдает ошибку.
Возможно где-то что-то не так. Вот что я имел в виду полный код
[vba]
Код
Private Sub Comma() Dim arrPred(), arrBase(), dicBase As Object Dim lLastRow As Long Dim i As Long, r As Long Application.ScreenUpdating = False Application.Calculation = xlManual
alex77755, работает правильно, но по скорости выходит 9 сек, по сравнению с макросом Андрея 0,8сек разница существенная. Так что на нем и остановлюсь. Всем спасибо, тема в полностью раскрыта и благодаря разным примерам буду осваивать работу с массивами и словарями (ответ самому себе: "давно уже пора лодарь " )
alex77755, работает правильно, но по скорости выходит 9 сек, по сравнению с макросом Андрея 0,8сек разница существенная. Так что на нем и остановлюсь. Всем спасибо, тема в полностью раскрыта и благодаря разным примерам буду осваивать работу с массивами и словарями (ответ самому себе: "давно уже пора лодарь " )DJ_Marker_MC
Думаю вариант Андрея выигрывает именно потому, что не просматривает всю огромную базу, а только пока найдёт все соответствия в последних записях. И спасибо что нашёл ночью эти 4 минуты (или полчаса...) Меня уже конкретно ломило...
Думаю вариант Андрея выигрывает именно потому, что не просматривает всю огромную базу, а только пока найдёт все соответствия в последних записях. И спасибо что нашёл ночью эти 4 минуты (или полчаса...) Меня уже конкретно ломило...Hugo
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
