Страницы: 1
RSS
Макрос копирования данных с критериями
 
Здравствуйте, стоит задача составить макрос для копирования данных с одного листа по критериям в другой. На просторах интернета нашел похожую, но все равно иную и попытался этот макрос переделать по нужную мне задачу. И вот он вроде бы работает, но криво. Прошу помощи разобраться. Сама задача звучит так:  Нужно чтобы данные с листа 2 копировались на лист 1 по критерию в столбце С. Подобных строк в листе 2 будут около 250, а листе 1 зависит от заказа.
Код
Sub Копирование()
AllRecs = Application.WorksheetFunction.CountA(Sheets("1").Range("C:C")) ' Получение количества строк на листе 1 (подсчет значений в столбце B)
cAllRecs = Application.WorksheetFunction.CountA(Sheets("2").Range("B:B")) 'Аналогично для листа 2
For CurRec = 1 To AllRecs
For cRecs = 3 To cAllRecs
    If Sheets("1").Cells(CurRec, 3) = Sheets("2").Cells(cRecs, 2) Then 'сверка критериев если Они равны то:
    'в этой строке указанным ячейкам присвоить значения из листа 1
    Sheets("1").Cells(cRecs, 6) = Sheets("2").Cells(CurRec, 3)
    Sheets("1").Cells(cRecs, 7) = Sheets("2").Cells(CurRec, 4)
    End If 'конец условия
Next cRecs 'следующая строка на Листе2
'После  окончания проверки на Листе 2 возвращаемся на Лист 1 за следующей суммой критериев:
Next CurRec
End Sub
 
Конкретно для вашего примера:
Код
Sub Копирование()
AllRecs = Sheets("1").Cells(Sheets("1").Rows.Count, 3).End(xlUp).Row
cAllRecs = Sheets("2").Cells(Sheets("2").Rows.Count, 2).End(xlUp).Row
For CurRec = 1 To AllRecs
For cRecs = 2 To cAllRecs
    If Sheets("1").Cells(CurRec, 3) = Sheets("2").Cells(cRecs, 2) Then 'сверка критериев если Они равны то:
    'в этой строке указанным ячейкам присвоить значения из листа 1
    Sheets("1").Cells(CurRec, 6) = Sheets("2").Cells(cRecs, 3)
    Sheets("1").Cells(CurRec, 7) = Sheets("2").Cells(cRecs, 4)
    End If 'конец условия
Next cRecs 'следующая строка на Листе2
'После  окончания проверки на Листе 2 возвращаемся на Лист 1 за следующей суммой критериев:
Next CurRec
End Sub
 
Александр Макаров, Спасибо огромнейшее, чувствовал, что решение уже где-то близко)  Но т.к. в VBA новичок не понял куда копать  :D
Страницы: 1
Наверх