Доброго времени суток! Недавно создавал тему, тут. Мне помогли, но столкнулся с еще одной проблемой. На листе2 имеются критерии их я пометил цветами, например С1 и С2 это один критерий для поиска. Нужна помощь в нахождении с Листа1 и перенос на Лист2, по данным критериям(их 5). Если такого критерия нет, или есть всего один С1, а С2 нету. То не нужно чтобы он его показывал. Спасибо за помощь.
На листе2 пишите критерии с точкой, а не с запятой, т.к. на листе1 числа с точкой. Я изменил у двух критериев, Вы сделайте у остальных. В самом файле макроса нет.
Макрос
Код
Sub Получить_по_критериям()
Dim shSrc As Worksheet, shRes As Worksheet, arrSrc(), arrCrit()
Dim lr As Long, lc As Long, lrRes As Long
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set shSrc = Worksheets("Лист1")
Set shRes = Worksheets("Лист2")
lr = shRes.Cells(shRes.Rows.Count, "B").End(xlUp).Row
If lr > 4 Then
shRes.Rows("5:" & lr).ClearContents
End If
lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
arrSrc() = shSrc.Range("A1:K" & lr).Value
lc = shRes.Cells(1, shRes.Columns.Count).End(xlToLeft).Column
arrCrit() = shRes.Range(shRes.Cells(1, "C"), shRes.Cells(2, lc)).Value
lrRes = 4
For j = 1 To UBound(arrCrit, 2)
For i = 2 To UBound(arrSrc)
If arrSrc(i, 8) = arrCrit(1, j) Then
If arrSrc(i, 10) = arrCrit(2, j) Then
lrRes = lrRes + 1
shSrc.Range(shSrc.Cells(i, "A"), shSrc.Cells(i, "K")).Copy shRes.Cells(lrRes, "B")
End If
End If
Next i
Next j
Application.ScreenUpdating = True
MsgBox "Готово!", vbInformation
End Sub
Karataev написал: На листе2 пишите критерии с точкой, а не с запятой, т.к. на листе1 числа с точкой. Я изменил у двух критериев, Вы сделайте у остальных.В самом файле макроса нет.
Спасибо большое, получается нужно будет для других критериев в макросе дописывать?
Guns86, макрос берет критерии из листа 2, из строки 1 и 2, начиная со столбца C. PS. Не цитируйте посты целиком. Чтобы ответить, не нужно щелкать кнопку "Цитировать", а достаточно прокрутить страницу вниз и там будет поле для написания поста. Если хотите к кому-то обратиться, то или просто напишите ник, или внизу справа поста есть ссылка Имя, которая вставит ник форумчанина в Ваш пост.
Karataev,Попрошу еще раз помочь) Вообщем вставил ваш макрос в эксель который тут в теме, все работает идеально. Перенес макрос в другой эксель, создал там 2 листа. Сохранил все места ячеек, и при включении макроса, он как будто не то берет и не правильно ставит. Почему? Скрины загрузил, один где все идеально, а другой где я пробовал в другой эксель
Karataev,Ну в другом экселе, так же сделал как и на примере. То есть в макросе коде, он берет ведь по заданным ячейкам, диапазоны определенные. И я так же сделал в другом экселе, положение их, чтобы макрос работал правильно.
Точной проблемы пока не понял, но на скрине видно, что в КФ 3 подставляется страна. Предположу, что на листе1 столбцы расположены не так, как в файле, который Вы предоставили на форуме.
Karataev, Вот тот файл, там на Листе1 я беру информацию с листа resultats. Вроде все подставленно нормально. Но почему то он не так вставляет, смещает.
Проблема была из-за формул - макрос копировал не только данные, но и формулы, а формулы подставляли неправильные данные. Теперь макрос копирует только данные без формул, без оформления. Если данные будут вставляться в неправильном виде, то заранее на листе2 настройте у целых столбцов нужный формат.
Макрос
Код
Sub Получить_по_критериям()
Dim shSrc As Worksheet, shRes As Worksheet, arrSrc(), arrCrit()
Dim lr As Long, lc As Long, lrRes As Long
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set shSrc = Worksheets("Лист1")
Set shRes = Worksheets("Лист2")
lr = shRes.Cells(shRes.Rows.Count, "B").End(xlUp).Row
If lr > 4 Then
shRes.Rows("5:" & lr).ClearContents
End If
lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
arrSrc() = shSrc.Range("A1:K" & lr).Value
lc = shRes.Cells(1, shRes.Columns.Count).End(xlToLeft).Column
arrCrit() = shRes.Range(shRes.Cells(1, "C"), shRes.Cells(2, lc)).Value
lrRes = 4
For j = 1 To UBound(arrCrit, 2)
For i = 2 To UBound(arrSrc)
If arrSrc(i, 8) = arrCrit(1, j) Then
If arrSrc(i, 10) = arrCrit(2, j) Then
lrRes = lrRes + 1
shSrc.Range(shSrc.Cells(i, "A"), shSrc.Cells(i, "K")).Copy
shRes.Cells(lrRes, "B").PasteSpecial (xlPasteValues)
End If
End If
Next i
Next j
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Готово!", vbInformation
End Sub