Доброго времени суток. Имеется выгрузка файла из interbase БД (gdb). По каждому залоговому билету (столбец 4) проводятся операции выдачи кредита (код 2, столбец 6, описание операции в столбце 7), а также его возврату (код 11, столбец 6) либо инкассации (код 43, столбец 6) Задача: проверить, что операции выдачи и возврата (инкассации) по залоговому билету с таким-то номером совпадают. Т.е. необходимо проверить, что сколько выдано, столько и возвращено. Если не совпадают, то данные выводятся на "Лист1". Написал макрос (кнопка "Проверить"), но время работы занимает очень продолжительное время, учитывая, что строк на листе более 200 000 (двухсот тысяч). Подскажите, пожалуйста, можно ли ускорить работу макроса? Данные команды прирост в скорости не дают:
Если убрать в цикле совершенно не нужное Sheets("OPERZB").Select и чуть переписать, чтоб избавиться от Sheets("Лист1").Select - то уже шевелится заметно быстрее. Но вообще конечно на первый взгляд там можно ускорять чуть ли не каждую строку, а лучше всё переписать на массивы и словарь
Может так? Не вполне правда понял по коду что нужно... И вывожу только код и разницу - зачем там эти исходные? Да и не хотелось усложнять, поздно уже...
Код
Sub tt()
Dim a, b, c, d, i&
a = [Таблица1].Columns(4).Value
b = [Таблица1].Columns(6).Value
c = [Таблица1].Columns(33).Value
d = [Таблица1].Columns(9).Value
With CreateObject("scripting.dictionary"): .comparemode = 1
For i = 1 To UBound(a)
Select Case True
Case b(i, 1) & c(i, 1) = "2"
.Item(a(i, 1)) = .Item(a(i, 1)) + d(i, 1)
Case b(i, 1) & c(i, 1) = "11"
.Item(a(i, 1)) = .Item(a(i, 1)) - d(i, 1)
Case Trim(b(i, 1)) = "43"
.Item(a(i, 1)) = .Item(a(i, 1)) - d(i, 1)
End Select
Next
ii = -1: a = Array(.keys, .items)
For i = 1 To UBound(a(0))
If a(1)(i) <> 0 Then
ii = ii + 1: a(0)(ii) = a(0)(i): a(1)(ii) = a(1)(i)
End If
Next
End With
With Sheets("Лист1")
.UsedRange.Offset(2).Clear
If ii > -1 Then
.[a3].Resize(ii + 1) = Application.Transpose(a(0))
.[d3].Resize(ii + 1) = Application.Transpose(a(1))
End If
End With
MsgBox "Проверка выполнена", vbInformation, "Внимание!"
End Sub
С 43 Вы правильно понимаете. Это инкассация, что аналогично возврату (т. е. выдали кредит на 1000, должны сделать возврат либо инкассацию на 1000), поэтому, верно, необходимо отнимать. С кодом разбираюсь, т. к. до этого не имел дела с массивами. Спасибо за помощь.
Тогда проще в код добавить ещё два словаря - в одном собирать все выдачи, во втором все возвраты. В итоге сформировать массив пошире, но выгружать/заполнять его надёжнее иначе - номера и результат можно как сейчас, а выдачи/возвраты извлекать индивидуально по каждому ключу-номеру. Хотя вообще и результат тоже лучше бы индивидуально извлекать - т.к. расположение пар ключ-значение в словаре не гарантируется. И вообще тогда можно обойтись двумя словарями - выдачи и возвраты, а в финале цикл по ключам и где разница не 0 - тех и выводим. Но тогда код нужно почти весь переделывать. Но переделывать некогда.
Hugo написал: можно обойтись двумя словарями - выдачи и возвраты
Чуть изменил код. Теперь выводятся выдачи и возвраты. Но не могу добиться, чтоб не выводились данные, если в 33 столбце есть какое-либо значение (т.е. в примере № 300000013 не должен выводится, т.к. он считается удаленным). В самом макросе я расписал в чем загвоздка. Посмотрите, пожалуйста.
Ну накрутили Гдеж там чуть? Я в Вашем коде не разобрался, проще другой написать. Всё ведь можно сделать намного проще, если создать для словаря переменную
Код
Option Explicit
Sub tt()
Dim a, b, c, d, i&
Dim d1 As Object, d2 As Object, k, razn As Double
a = [Таблица1].Columns(4).Value
b = [Таблица1].Columns(6).Value
c = [Таблица1].Columns(33).Value
d = [Таблица1].Columns(9).Value
Set d1 = CreateObject("scripting.dictionary"): d1.comparemode = 1 ' для выдач
Set d2 = CreateObject("scripting.dictionary"): d2.comparemode = 1 ' для возвратов
For i = 1 To UBound(a)
If Trim(c(i, 1)) = "" Then
Select Case Trim(b(i, 1))
Case "2"
d1.Item(a(i, 1)) = d1.Item(a(i, 1)) + d(i, 1) ' собираем выдачи
Case "11", "43"
d2.Item(a(i, 1)) = d2.Item(a(i, 1)) + d(i, 1) ' собираем возвраты
End Select
End If
Next
ReDim a(1 To d1.Count, 1 To 4): i = 0 'экономим переменные :)
For Each k In d1.keys 'перебор всех NZB
razn = d1.Item(k) - d2.Item(k) 'разница выдача-возврат
If razn <> 0 Then 'если разница не 0
i = i + 1 'увеличивем индекс
a(i, 1) = k ' заносим NZB
a(i, 2) = d1.Item(k) ' заносим выдачу
a(i, 3) = d2.Item(k) ' заносим возврат
a(i, 4) = razn ' заносим разницу
End If
Next
With Sheets("1") 'выводим на лист
.[d1] = "ДОЛГ" 'это можно сделать один раз вручную :)
.UsedRange.Offset(1).Clear
If i > 0 Then .Cells(2, 1).Resize(i, 4) = a
End With
MsgBox "Проверка выполнена!", vbInformation, "Внимание!"
End Sub
Надеюсь таблица генерится скриптом, и там не будет в данных/ячейках никаких лишних пробелов, что часто любят тыркать бабки... А то можно всюду навесить Trim()
P.S. Вообще в данном случае в словаре comparemode "рояли" не играет, т.к. там как ключи имеем числа, а не слова в разном регистре. Кстати, если вдруг эти числа где-то будут текстом - это уже будет другой ключ, в таком случае нужно все ключи приводить к тексту, я обычно навешиваю Trim() - так получим текст, и от пробелов подстрахуемся. Но при выгрузке получим тоже текст... правда который в данном случае Эксель обратно превратит в число.
Изменено: Hugo - 26.03.2016 13:07:14(оптимизировал код)