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

[Hugo121]

Public Sub materialykredit0()
    Dim Sht1 As Worksheet, Sht2 As Worksheet, flag As Boolean
    Dim a, aa, b, i As Long, k As Long
    
    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, 23)) 'массив "allwork_2009_year.xlsm" КРЕДИТ
            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, 19) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 23 наименование, копируем из работы в кассу
                           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]

[QUOTE=Hugo121;649828[/QUOTE]
Ура, работает.
Пиво с меня. Пока виртуальное конечно, но обещаю настоящее.
Спасибо

[Hugo121]

Ну и хорошо.
Единственное, хотел обратить внимание, что при таком копировании с помощью массива формулы преобразуются в значения, и во всей области массива, и переписываются на лист все данные из массива, тогда как при копировании поячеечно в ячейках, незатронутых копированием, остаётся прежняя формула или значение.
Так что тут надо смотреть по задаче, если нужно сохранить формулы в промежутках и данных не много, то можно работать с ячейками.
Ну а если формул нет, форматы копировать не нужно (остаются прежние листа), а данных много, то удобнее и быстрее загонять всё в массивы и их преобразовывать.

[kzld]

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

Public Sub materialykredit0()
    Dim Sht1 As Worksheet, Sht2 As Worksheet, flag As Boolean
    Dim a, aa, b, i As Long, k As Long
    
    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, 23)) 'массив "allwork_2009_year.xlsm" КРЕДИТ
            For i = 1 To UBound(b)
            Select Case b(i, 1)
                Case 821,4 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, 19) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 23 наименование, копируем из работы в кассу
                           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

Там, где выделено красным, должно быть значение 821,4 именно с запятой. Макрос не желает воспринимать запятую. Как это можно побороть?

[nilem]

Попробуйте на 2 строки разбить
Case 821, 4
If b(i, 3) <> "" Then

[Hugo121]

А так:

Case "821,4"
If b(i, 3) <> "" Then

или так:

Select Case CStr(b(i, 1))
Case "821,4", "тут может быть другое значение"
If b(i, 3) <> "" Then

[kzld]

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

вырезано, как не относящееся к теме

Немножко переделал код, под другой файл получатель
И опять прошу помощи подправить макрос
Сумму, столбец 8 (или столбец 4 при обьявлении массива) в файле источнике, макрос упрямо пишет в 6 столбец в файле получателе, в то время как сумма должна быть в 21 столбце.
А в 21 столбец, макрос пишет #Н\Д

Public Sub reestr0()
    Dim Sht1 As Worksheet, Sht2 As Worksheet, flag As Boolean
    Dim a, aa, b
    Application.Calculation = xlCalculationManual
    
    For Each Sht1 In Workbooks("NR_100.00.030IVA.xlsm").Worksheets 'это файл NR_100.00.030IVA.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("E17:f664").ClearContents 'очищаем предыдущие значения
            Sht1.Range("U17:V664").ClearContents 'очищаем предыдущие значения
            a = Range(Sht1.Cells(17, 5), Sht1.Cells(664, 21)) 'куда писать данные с 17 строки 5 столбца, по 664 строку 21 столбца
            aa = Range(Sht1.Cells(17, 1), Sht1.Cells(664, 1)) ' массив адресов т.е соответствие дат
            b = Range(Sht2.Cells(3, 5), Sht2.Cells(5000, 13)) 'значит, что берём в массив с 5-ого по 13-ый столбец, но в массиве они будут с 1-го по 9-й элемент
            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, 2) = b(i, 9) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 9 РНН, копируем из работы в кассу
                           a(k, 3) = b(i, 4) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 8 сумма, копируем из работы в кассу
                           Exit For
                    End If
                    End If
                Next k
                End If
            End Select
            Next i
            Range(Sht1.Cells(17, 4), Sht1.Cells(664, 21)) = a
        End If
    Next
Application.Calculation = xlCalculationAutomatic
End Sub

[kzld]

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

Public Sub materialykredit0()
    Dim Sht1 As Worksheet, Sht2 As Worksheet, flag As Boolean
    Dim a, aa, b, i As Long, k As Long
    
    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, 23)) 'массив "allwork_2009_year.xlsm" КРЕДИТ
            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, 19) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 23 наименование, копируем из работы в кассу
                           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

Уважаемый Hugo121. Ну и все остальные кто знает
Как в представленном макросе добавить ещё условия копирования.
Не только наименование и сумму, но и другие значения
Я так полагаю, что после выделено красным в теле макроса нужно ещё что то дописать, пробовал

If aa(k, 1) = b(i, 3) Then 'если в кассе КРЕДИТ НАИМЕНОВАНИЕ пусто, смотрим кассу столбец 1 дата, если совпадает тогда
                           a(k, 1) = b(i, 9) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 9 РНН, копируем из работы в кассу
                           a(k, 2) = b(i, 10) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 14 №счёта, копируем из работы в кассу                          
 a(k, 3) = b(i, 12) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 15 дата счёта, копируем из работы в кассу
  a(k, 4) = b(i, 4) 'если в кассе КРЕДИТ наименование пусто, смотрим в работу столбец 4 сумма, копируем из работы в кассу

Не получается

[Hugo121]

Нет сейчас под рукой примеров - поэтому только совет: при пошаговом прогоне кода посмотрите в редакторе в окне Locals содержимое массива b. Подозреваю, что Вы не те ячейки копируете (b(i,12), b(i,4)).

[kzld]

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

Нет сейчас под рукой примеров - поэтому только совет: при пошаговом прогоне кода посмотрите в редакторе в окне Locals содержимое массива b. Подозреваю, что Вы не те ячейки копируете (b(i,12), b(i,4)).

Спасибо за быстрый ответ.
Пошагово я пробовал.
12 листов в исходном файле по 1000 строк на листе, 12 листов в файле приёмнике также по 1000 строк. Можно неделю нажимать F8