Страницы: 1
RSS
Макрос для поиска не пустых ячеек по горизонтали
 
Добрый день уважаемые форумчане.
Такой вопрос возник.
Есть список на Листе 1 и вот с этого списка нужно из первого столбца перенести (в данном случае имена сотрудников) ячейки на против которых в строке есть от 5 и более (цифра условная тоже - пока неизвестно сколько не пустых ячеек нужно находить - диапазон поиска будет менятся неоднократно) заполненых ячеек ( не пустых ). Столбцов всего планируется около 7- 10 в которых будут эти данные (в примере 7).
Получается нужен ВПР только по горизонтали и который будет считать не пустые ячейки. Вот такая вот интересная задумка.
Буду рад любой помощи.
Пример приложил. На листе1 исходный список, на листе2 то что должно получится.
Изменено: Fsociety_ - 21.04.2019 11:48:59
 
Цитата
Fsociety_ написал:
Буду рад любой помощи
Любая помощь №1: цикл по строкам и проверка при помощи WorksheetFunction.CountA
 
Fsociety_, формулами тоже можно. только формулы отдыхают
 
Fsociety_, я изменил название темы - убрал упоминание ВПР. Есть вопросы:
- правильно ли я понимаю, что на втором листе нужно вывести список только всех подходящих имён?
- если это так, то откуда на втором листе появилась пустая ячейка (строка 4)?
- откуда взялось значение "столбец" в пятой строке?
===
P.S. Макрос у меня готов.
 
Цитата
Юрий М написал:
- если это так, то откуда на втором листе появилась пустая ячейка (строка 4)?- откуда взялось значение "столбец" в пятой строке?
это просто пример, там просто вывел имена которые должны получиться) не обращайте внимание на столбец и пустую строку, это не имеет значение)
Изменено: Fsociety_ - 21.04.2019 12:44:36
 
Цитата
Юрий М написал:
правильно ли я понимаю, что на втором листе нужно вывести список только всех подходящих имён?
да, в принципе можно и в том же листе, без разницы. Мне нужна только основа кода, а там я уже дальше буду смотреть что да как компоновать. т.к  я еще не знаю как все это будет работать и там будет все меняться по 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
 
Юрий М,как раз таки должна с первого листа происходить активация, там основная работа будет происходить. А на второй лист просто вставляться результат должен
Изменено: Fsociety_ - 21.04.2019 13:01:21
 
И Вы об этом сразу сказали в стартовом сообщении?
 
Код
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 прошу прощения за тупой вопрос. Возможно я что то не вижу и что то делаю не так)
 
Цитата
Fsociety_ написал:
убрал знак">" для поиска именно 5 ячеек. Но что то не работает.
Проделал то же самое - работает )
 
Цитата
Юрий М написал:
работает )
ну работать то да, он работает, но только он все равно переносит даже те строки в которых 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) он выдает ошибку на последней строке. Вопрос: можно ли это пофиксить исправив сам код или ставить проверку не потеряв скорости работа макроса? Как это лучше и правильнее прописать в данном варианте кода ?

P.S Хотел бы узнать как будет лучше сделать.
Изменено: Fsociety_ - 22.04.2019 13:57:30
 
Уточните условия, при которых возникает ошибка. А ещё лучше покажите это в небольшом файле.
Очистил строку у Екатерины - ошибки нет.
 
Юрий М, Прошу прощения за долгий ответ небыло возможности. Так вот условие возникновения ошибки:
                   В случае если наш код ищет именно 4 заполненных ячейки, но в диапазоне поиска нету ни одной строки заполненной на 4 ячейки (т.е есть строки только с заполненными на 3,5,6 ячеек и т.д), то выбивает ошибку в последней строке. Если в диапазоне находит 4 ячейки то все норм. Запустите макрос как в этом примере, в диапазоне нету строк с заполненными 4 ячейками.

P.S временно втыкнул затычку "Go to error". Но хотел узнать по поводу правильного решения данного конфликта
Изменено: Fsociety_ - 23.04.2019 16:26:33
 
Теперь понял ))
Код
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
 
Юрий М, Спасибо большое, так лучше выглядит) Теперь знаю чуть больше)
Страницы: 1
Наверх