Добрый день уважаемые форумчане. Такой вопрос возник. Есть список на Листе 1 и вот с этого списка нужно из первого столбца перенести (в данном случае имена сотрудников) ячейки на против которых в строке есть от 5 и более (цифра условная тоже - пока неизвестно сколько не пустых ячеек нужно находить - диапазон поиска будет менятся неоднократно)заполненых ячеек ( не пустых ). Столбцов всего планируется около 7- 10 в которых будут эти данные (в примере 7). Получается нужен ВПР только по горизонтали и который будет считать не пустые ячейки. Вот такая вот интересная задумка. Буду рад любой помощи. Пример приложил. На листе1 исходный список, на листе2 то что должно получится.
Fsociety_, я изменил название темы - убрал упоминание ВПР. Есть вопросы: - правильно ли я понимаю, что на втором листе нужно вывести список только всех подходящих имён? - если это так, то откуда на втором листе появилась пустая ячейка (строка 4)? - откуда взялось значение "столбец" в пятой строке? === P.S. Макрос у меня готов.
Юрий М написал: правильно ли я понимаю, что на втором листе нужно вывести список только всех подходящих имён?
да, в принципе можно и в том же листе, без разницы. Мне нужна только основа кода, а там я уже дальше буду смотреть что да как компоновать. т.к я еще не знаю как все это будет работать и там будет все меняться по 200 раз.
Fsociety_ написал: не обращайте внимание на столбец и пустую строку, это не имеет значение)
Зачем тогда показывать такой пример? Ведь это лишняя переписка... См. вариант. Выполнять при активном втором листе.
Код
Sub Macro1()
Dim i As Long, LastRow As Long, FreeRow As Long, iColumn As Long
Application.ScreenUpdating = False
iColumn = 5 'Количество заполненных ячеек в строке
FreeRow = 4
LastRow = Cells(Rows.Count, 4).End(xlUp).Row
Range(Cells(4, 4), Cells(LastRow + 1, 4)).ClearContents
With Sheets("Лист1")
LastRow = .Cells(Rows.Count, 4).End(xlUp).Row
For i = 5 To LastRow
If Application.WorksheetFunction.CountA(Range(.Cells(i, 3), .Cells(i, 9))) >= iColumn Then '9 - правая граница диапазона
Cells(FreeRow, 4) = .Cells(i, 2)
FreeRow = FreeRow + 1
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Юрий М,как раз таки должна с первого листа происходить активация, там основная работа будет происходить. А на второй лист просто вставляться результат должен
Sub Macro1()
Dim i As Long, LastRow As Long, FreeRow As Long, iColumn As Long
Application.ScreenUpdating = False
iColumn = 5 'Количество заполненных ячеек в строке
FreeRow = 4
With Sheets("Лист2")
LastRow = .Cells(Rows.Count, 4).End(xlUp).Row
Range(.Cells(4, 4), .Cells(LastRow + 1, 4)).ClearContents
LastRow = Cells(Rows.Count, 4).End(xlUp).Row
For i = 5 To LastRow
If Application.WorksheetFunction.CountA(Range(Cells(i, 3), Cells(i, 9))) >= iColumn Then '9 - правая граница диапазона
.Cells(FreeRow, 4) = Cells(i, 2)
FreeRow = FreeRow + 1
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Юрий М, немного потестировал код, при больших объемах данных тормозит и ексель грозится крашем, но в итоге срабатывает. Заполнил в искомом столбце с именами 6000 строк. Вопрос, возможно ли ускорить макрос? Т.к он будет в куупе с другими работать и немного переделываться, то все это вместе нехило подгрузит систему.
'https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=116466&TITLE_SEO=116466-makros-na-osnove-vpr-dlya-poiska-ne-pustykh-yacheek-po-gorizontali#postform
Sub Macro1()
Dim i As Long, j As Long, LastRow As Long, iColumn As Long, Arr(), x As Long, Counter As Long
iColumn = 5 'Количество заполненных ячеек в строке
LastRow = Cells(Rows.Count, 4).End(xlUp).Row
Arr = Range(Cells(5, 2), Cells(LastRow, 9)).Value
ReDim arrout(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) <> "" Then Counter = Counter + 1
If Counter >= iColumn Then
x = x + 1
arrout(x, 1) = Arr(i, 1)
Exit For
End If
Next
Counter = 0
Next
With Sheets("Лист2")
LastRow = .Cells(Rows.Count, 4).End(xlUp).Row
Range(.Cells(4, 4), .Cells(LastRow + 1, 4)).ClearContents
.Range("D4").Resize(x, 1).Value = arrout
End With
End Sub
Юрий М, Спасибо большое так лучше. но я так посмотрел, к примеру я щас хотел поменять диапазон с 5 и больше на ровно 5 ячеек для поиска. И я так понимаю за это отвечает строка:
Код
If Counter >= iColumn Then
убрал знак">" для поиска именно 5 ячеек. Но что то не работает.
P.S прошу прощения за тупой вопрос. Возможно я что то не вижу и что то делаю не так)
ну работать то да, он работает, но только он все равно переносит даже те строки в которых 6 ячеек и 7 и 8 а нужно конкретно 5 к примеру. Он переносит все что больше 5.
Можно даже без дополнительной проверки: достаточно вынести имеющуюся за пределы цикла:
Код
Sub Macro1()
Dim i As Long, j As Long, LastRow As Long, iColumn As Long, Arr(), x As Long, Counter As Long
iColumn = 5 'Количество заполненных ячеек в строке
LastRow = Cells(Rows.Count, 4).End(xlUp).Row
Arr = Range(Cells(5, 2), Cells(LastRow, 9)).Value
ReDim arrout(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) <> "" Then Counter = Counter + 1
Next
If Counter = iColumn Then
x = x + 1
arrout(x, 1) = Arr(i, 1)
End If
Counter = 0
Next
With Sheets("Лист2")
LastRow = .Cells(Rows.Count, 4).End(xlUp).Row
Range(.Cells(4, 4), .Cells(LastRow + 1, 4)).ClearContents
.Range("D4").Resize(x, 1).Value = arrout
End With
End Sub
Только Вы меняете условия: ведь изначально что писали? - 5 заполненных ячеек и больше - подходит. Так и было сделано.
Юрий М написал: 5 заполненных ячеек и больше - подходит. Так и было сделано.
ну это было условно, я ведь уже заранее понимал что этот параметр смогу поменять на точное соответствие. в первом примере так и было но он с большими данными не справлялся, но он был более понятен, а этот последний пример не совсем понятен и уже не срабатывал такой номер. Простите за лишнюю сумотоху и доделку.
Спасибо еще раз большое, дальше сам попробую разбираться)
Юрий М, добрый лень, прошу прощения за доставучесть. Но сегодня еще потестил и вот такой вопрос. Макрос при работае к примеру ищет конкретное кол-во заполненных ячеек, и вот если во всем диапазоне работы он не нашел нужного кол-ва заполненных ячеек (к примеру там были 2 и 3 заполненные и ни одной строки заполненной на 4) он выдает ошибку на последней строке. Вопрос: можно ли это пофиксить исправив сам код или ставить проверку не потеряв скорости работа макроса? Как это лучше и правильнее прописать в данном варианте кода ?
Юрий М, Прошу прощения за долгий ответ небыло возможности. Так вот условие возникновения ошибки: В случае если наш код ищет именно 4 заполненных ячейки, но в диапазоне поиска нету ни одной строки заполненной на 4 ячейки (т.е есть строки только с заполненными на 3,5,6 ячеек и т.д), то выбивает ошибку в последней строке. Если в диапазоне находит 4 ячейки то все норм. Запустите макрос как в этом примере, в диапазоне нету строк с заполненными 4 ячейками.
P.S временно втыкнул затычку "Go to error". Но хотел узнать по поводу правильного решения данного конфликта
Sub Macro1()
Dim i As Long, j As Long, LastRow As Long, iColumn As Long, Arr(), x As Long, Counter As Long
iColumn = 4 'Количество заполненных ячеек в строке
LastRow = Cells(Rows.Count, 4).End(xlUp).Row
Arr = Range(Cells(5, 2), Cells(LastRow, 9)).Value
ReDim arrout(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) <> "" Then Counter = Counter + 1
Next
If Counter = iColumn Then
x = x + 1
arrout(x, 1) = Arr(i, 1)
End If
Counter = 0
Next
With Sheets("Лист2")
LastRow = .Cells(Rows.Count, 4).End(xlUp).Row
Range(.Cells(4, 4), .Cells(LastRow + 1, 4)).ClearContents
If x > 0 Then .Range("D4").Resize(x, 1).Value = arrout 'Добавлена проверка
End With
End Sub
'См. строку № 20