Макрос, вытащить данные и расставить по местам

[kzld]

Имеем вот такой макрос

Public Sub materialykredit01()
    Dim Sht1 As Worksheet, Sht2 As Worksheet, flag As Boolean
    For Each Sht1 In Workbooks("Materialy_2009_add203.xlsm").Worksheets 'это файл Materialy_2009_add203.xlsm
        flag = False 'false если неправильно
        For Each Sht2 In Workbooks("allwork_2009_year.xlsm").Worksheets 'это файл allwork_2009_year.xlsm
            If Sht2.Name = Sht1.Name Then 'это сооветствие имён листов в книгах
                flag = True 'true - правильно
                Exit For 'выход
            End If
            Next 'следующий
        If flag Then 'если флаг then (затем) тогда
            Sht1.Range("J8:K655").ClearContents 'очищаем предыдущие значения
            For I = 3 To 5000 'просматриваем файл "allwork_2009_year.xlsm" от 3 строки до 5000
                If Sht2.Cells(I, 5).Value = 202 And Sht2.Cells(I, 7).Value <> "" Then 'просматриваем столбец 5 "allwork_2009_year.xlsm" КРЕДИТ ищем 202, просматриваем столбец 7 дата
                    For k = 8 To 655 'ищем в кассе совпадение даты
                        If Sht1.Cells(k, 10).Value = 0 And Sht1.Cells(k, 1).Value = Sht2.Cells(I, 7).Value Then 'если в кассе КРЕДИТ НАИМЕНОВАНИЕ пусто, смотрим кассу столбец 1 дата, если совпадает тогда
                           Sht1.Cells(k, 10).Value = Sht2.Cells(I, 12).Value 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 12 наименование, копируем из работы в кассу
                           Sht1.Cells(k, 11).Value = Sht2.Cells(I, 8).Value 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 8 сумма, копируем из работы в кассу
                Exit For
                End If
                    Next k
                End If
            Next I
        End If
    Next
End Sub

Суть работы макроса
просматриваем файл allwork_2009_year.xlsm ищем в 5 столбце значение равное 202. Смотрим этот же файл столбец 7 - это дата, запоминаем. Переходим в файл Materialy_2009_add203.xlsm просматриваем столбец 1 - это тоже дата, находим соответствие. Смотрим по строке столбец 10, если пусто вставляем значением из столбца 12 файла allwork_2009_year.xlsm . Если не пусто, спускаемся на строку ниже, если пусто - вставляем, если нет - спускаемся ещё на строку вниз.

Так вот , желаю добавить ещё одно условие.
Кроме поиска значения 202 в файле allwork_2009_year.xlsm , осуществить поиск значения 203

[Hugo121]

Пример бы увидеть...
На массивах аналогичный код будет работать в 38 раз быстрее.
Но правда если в промежутке на листе нужны формулы - массивы не годятся.
Кроме того, можно сделать код на Find - я тут недавно alexey_nv86 примеры приводил
http://www.programmersforum.ru/showthread.php?t=119802

[kzld]

Сообщение от Hugo121

Пример бы увидеть...
На массивах аналогичный код будет работать в 38 раз быстрее.

Интересно. Подскажите с чего начать.
А вот и пример

[Hugo121]

Только заменил обращение к листу на массив (ну и пересчёт перенёс в конец):

Public Sub materialykredit0_2()
Dim tm
tm = Timer
    Dim Sht1 As Worksheet, Sht2 As Worksheet, flag As Boolean
    Dim a, b
    Application.Calculation = xlCalculationManual
    
    For Each Sht1 In Workbooks("Materialy_2009_add203.xlsm").Worksheets 'это файл Materialy_2009_add203.xlsm
        flag = False 'false если неправильно
        For Each Sht2 In Workbooks("allwork_2009_year.xlsm").Worksheets 'это файл allwork_2009_year.xlsm
            If Sht2.Name = Sht1.Name Then 'это сооветствие имён листов в книгах
                flag = True 'true - правильно
                Exit For 'выход
            End If
            Next 'следующий
        If flag Then 'если флаг then (затем) тогда
            Sht1.Range("J8:K655").ClearContents 'очищаем предыдущие значения
            a = Range(Sht1.Cells(8, 10), Sht1.Cells(655, 11))
            aa = Range(Sht1.Cells(8, 1), Sht1.Cells(655, 1))
            b = Range(Sht2.Cells(3, 5), Sht2.Cells(5000, 12))
            For i = 1 To UBound(b)
                If b(i, 1) = 202 Then
                If b(i, 3) <> "" Then 'просматриваем столбец 5 "allwork_2009_year.xlsm" КРЕДИТ ищем 202, просматриваем столбец 7 дата
                For k = 1 To UBound(a) 'ищем в кассе совпадение даты
                    If a(k, 1) = 0 Then
                    If aa(k, 1) = b(i, 3) Then 'если в кассе КРЕДИТ НАИМЕНОВАНИЕ пусто, смотрим кассу столбец 1 дата, если совпадает тогда
                           a(k, 1) = b(i, 8) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 12 наименование, копируем из работы в кассу
                           a(k, 2) = b(i, 4) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 8 сумма, копируем из работы в кассу
                           Exit For
                    End If
                    End If
                Next k
                End If
                End If
            Next i
            Range(Sht1.Cells(8, 10), Sht1.Cells(655, 11)) = a
        End If
    Next
Application.Calculation = xlCalculationAutomatic
Debug.Print Timer - tm
End Sub

Разница по времени не 38 раз, вероятно потому, что там не 5000-3 внутренних цикла, а только 48:
1.296875
0.21875
1.296875
0.265625

Отключил это условие - массивы отработали за 29 секунд, Ваш код 822:
29.23438
822.2539

Забыл про главный вопрос:
If (Sht2.Cells(i, 5).Value = 202 Or Sht2.Cells(i, 5).Value = 203) And Sht2.Cells(i, 7).Value <> "" Then 'просматриваем столбец 5 "allwork_2009_year.xlsm" КРЕДИТ ищем 202, просматриваем столбец 7 дата
скобки можно не ставить, но так понятнее.
Или в моём коде
If b(i, 1) = 202 Or b(i, 1) = 203 Then

или через Select Case:

            For i = 1 To UBound(b)
            Select Case b(i, 1)
                Case 202, 203
                If b(i, 3) <> "" Then 'просматриваем столбец 5 "allwork_2009_year.xlsm" КРЕДИТ ищем 202, просматриваем столбец 7 дата
                For k = 1 To UBound(a) 'ищем в кассе совпадение даты
                    If a(k, 1) = 0 Then
                    If aa(k, 1) = b(i, 3) Then 'если в кассе КРЕДИТ НАИМЕНОВАНИЕ пусто, смотрим кассу столбец 1 дата, если совпадает тогда
                           a(k, 1) = b(i, 8) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 12 наименование, копируем из работы в кассу
                           a(k, 2) = b(i, 4) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 8 сумма, копируем из работы в кассу
                           Exit For
                    End If
                    End If
                Next k
                End If
            End Select
            Next i

[kzld]

Спасибо за ответ, однако небольшая просьба.
Соедините Ваш макрос с Вашими же дополнениями, чтобы выбирались значения и 202 и 203

[Hugo121]

Но проверьте внимательно результат.

Public Sub materialykredit0()
    Dim Sht1 As Worksheet, Sht2 As Worksheet, flag As Boolean
    Dim a, aa, b
    Application.Calculation = xlCalculationManual
    
    For Each Sht1 In Workbooks("Materialy_2009_add203.xlsm").Worksheets 'это файл Materialy_2009_add203.xlsm
        flag = False 'false если неправильно
        For Each Sht2 In Workbooks("allwork_2009_year.xlsm").Worksheets 'это файл allwork_2009_year.xlsm
            If Sht2.Name = Sht1.Name Then 'это сооветствие имён листов в книгах
                flag = True 'true - правильно
                Exit For 'выход
            End If
            Next 'следующий
        If flag Then 'если флаг then (затем) тогда
            Sht1.Range("J8:K655").ClearContents 'очищаем предыдущие значения
            a = Range(Sht1.Cells(8, 10), Sht1.Cells(655, 11))
            aa = Range(Sht1.Cells(8, 1), Sht1.Cells(655, 1))
            b = Range(Sht2.Cells(3, 5), Sht2.Cells(5000, 12))
            For i = 1 To UBound(b)
            Select Case b(i, 1)
                Case 202, 203
                If b(i, 3) <> "" Then 'просматриваем столбец 5 "allwork_2009_year.xlsm" КРЕДИТ ищем 202, просматриваем столбец 7 дата
                For k = 1 To UBound(a) 'ищем в кассе совпадение даты
                    If a(k, 1) = 0 Then
                    If aa(k, 1) = b(i, 3) Then 'если в кассе КРЕДИТ НАИМЕНОВАНИЕ пусто, смотрим кассу столбец 1 дата, если совпадает тогда
                           a(k, 1) = b(i, 8) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 12 наименование, копируем из работы в кассу
                           a(k, 2) = b(i, 4) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 8 сумма, копируем из работы в кассу
                           Exit For
                    End If
                    End If
                Next k
                End If
            End Select
            Next i
            Range(Sht1.Cells(8, 10), Sht1.Cells(655, 11)) = a
        End If
    Next
Application.Calculation = xlCalculationAutomatic
End Sub

[kzld]

Первое испытание - полёт нормальный
Спасибо

[kzld]

Сообщение от Hugo121

Но проверьте внимательно результат.

  вырезано

И ещё прошу помощи.
Какие значения надо изменить в макросе, что-бы из файла allwork_2009_year.xlsm бралось значение не 12 а 23 столбца

[Hugo121]

Вот это
b = Range(Sht2.Cells(3, 5), Sht2.Cells(5000, 12))
значит, что берём в массив с 5-ого по 12-ый столбец, но в массиве они будут с 1-го по 8-й элемент.
Вот исходя из этого и меняйте размер и соответственно всюду обращение к элементам массива.
Можно отдельно создать массив именно только для 23-го столбца, как я сделал массив aa для дат.

[kzld]

Сообщение от Hugo121

Вот это
b = Range(Sht2.Cells(3, 5), Sht2.Cells(5000, 12))
значит, что берём в массив с 5-ого по 12-ый столбец, но в массиве они будут с 1-го по 8-й элемент.
Вот исходя из этого и меняйте размер и соответственно всюду обращение к элементам массива.
Можно отдельно создать массив именно только для 23-го столбца, как я сделал массив aa для дат.

Два часа просидел, но так и не смог добиться желаемого результата.
Я только начинаю изучать VB. Всё же попрошу Вас помочь мне, вытащитьзначение 23 столбца, вместо 12