Выборка различных значений без пустот и чисел

[RubidoN]

Всех горячо приветствую!

Работаю начальником склада и чтобы показать ребятам (да и самому следить за производительностью за месяц), создал вот такой .xlsm файлик(приложил, он почти как оригинал, только без финансовых данных). Всё полностью "самоучно-рукописное"(формулы, способы реализации) поэтому сильно тапками не кидайтесь

Ближе к сути: На листе "Экземпляры" есть кнопочка "Выборка ФИО", к ней присвоен макрос(о нём, противном, и будет речь). В чем его работа: есть два листа с данными, макрос создаёт список уникально-различных ФИО(там список сотрудников повторяется ежедневно) из листа "Данные601". Нужно именно из этого листа, туда чаще и актуальнее поступает инфо.

И так, в корень и "сок" поста: Пытаюсь сделать гибкий(универсальный) макрос, который будет выводить в список только те ячейки, которые не содержат:

1. Числа
2. Пустые ячейки
3. И 1 гибкое(редактируемое) условие(например чтобы исключало в коллекцию ячейки которые содержат "Odis-"

Как только не "изгалялся", шестой день ищу способ. Многие способы не подходят, так как хочу привязать скрипт к кнопке(это позволяет бесконечно обновлять список). Почему именно через макрос, ведь можно через формулу массива!? Это сильно нагружает и без того мою "рукопопски" сделанные таблицы. От месяца к месяцу кол-во строк в листе "Данные601" может варьироваться от 700 до 1600 строк. Плюс второй лист.


Мне нравится что я могу вносить переменные(если они происходят и требуются) без корректировки целиком. И да, это "франкенштейн".

Sub FIO()
    Dim x, avArr, li As Long
    Dim avVals
    Dim rVals As Range, rResultCell As Range
    On Error Resume Next
    Set rVals = Sheets("Данные601").Range("$C:$C")
    If rVals Is Nothing Then
        Exit Sub
    End If
    If rVals.Count = 1 Then
        Exit Sub
    End If
    Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
    If rVals Is Nothing Then
        Exit Sub
    End If
    avVals = rVals.Value
    Set rResultCell = Sheets("Экземпляры").Range("A1:A2000")
    If rResultCell Is Nothing Then
        Exit Sub
    End If
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each x In avVals
            If Len(CStr(x)) Then
                .Add x, CStr(x)
                If Err = 0 Then
                    li = li + 1
                    avArr(li, 1) = x
                Else
                    Err.Clear
                End If
            End If
        Next
    End With
    If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Sheets("Экземпляры").Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A2:A2000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub

Лирика: И подскажите "самоучке" как работает функция "IsNumeric" и работает ли вообще!? В парочке примеров, чтобы понять как её "едят". Я пару дней пытался "приварить" её к "New Collection" не получалось. Может я и суть этой функции не правильно понял(вполне вероятно), но как только я её не подставлял и в какую только часть кода не "припихивал". Например:
For Each x In avVals
If IsNumeric(x) = False Then
.Add x, CStr(x)
If Err = 0 Then
li = li + 1
avArr(li, 1) = x
Else
Err.Clear
End If
End If
Next
Могу уверить вас что делал абсолютно очень разнообразными способами, даже так
IsNumeric x
Cell.Clear
И т.д. ... ... Ну самоучка! Мда... Буду рад инфо об этой "IsNumeric"


P.S. А почему здесь нельзя делать [SPOILER][/SPOILER]?

[jillitil]

поэтому сильно тапками не кидайтесь
И т.д. ... ... Ну самоучка!

Весь мир держится на самоучках. Кто не самоучка - тот балбес.

Функция IsNumeric(StringVariable$) говорит может ли текстовая строка (переменная или ячейка) StringVariable$ быть преобразована в число.

IsNumeric( "20.6" ) = TRUE
IsNumeric( "-4" ) = TRUE
IsNumeric( "Вася 20.6" ) = FALSE

Ваш "код" мягко говоря пустышка. Ниочём. Вообще. Просто надёрганные бессмысленно откуда-то команды.

Единственное что понял: из листа "Данные601", колонки "Ц" выбрать все ФИО по одному разу каждого человека. (п.п. 1,2,3 я понял). Что дальше? Куда этот список записать или что с ним делать потом?

[RubidoN]

Спасибо. Дааа, так и подумал что неправильно уловил суть функции "IsNumeric". Что ж спасибо большое.

По поводу что дальше со списком, я работаю с ним внутри файла по формулам. Список формируется на лист "Экземпляры", там у сотрудников кол-во обработанных единиц товара по разным складским операциям за месяц.

Мне нужен способ извлечь данные ФИО по этим условиям:

И так, в корень и "сок" поста: Пытаюсь сделать гибкий(универсальный) макрос, который будет выводить в список только те ячейки, которые не содержат:
Числа
Пустые ячейки
И 1 гибкое(редактируемое) условие(например чтобы исключало в коллекцию ячейки которые содержат "Odis-"

А код который закреплён в моём посте, это то что я сейчас имею. Настроил выборку различных ФИО, настроил чтобы пустые ячейки не включались в список, настроил сортировку с переменными, настроил чтобы список можно было сделать и не только 1 столбик(если понадобиться), а дальше ступор, не хватает знаний для написания макроса "для кнопки". Изыскания не дали подходящего решения. Вот и пришел за помощью.

[Serge 007]

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

как работает функция "IsNumeric"

IsNumeric

[jillitil]

После выполнения Sub в глобальной коллекции будет уникальный список ФИО.
Обращаться через WorkerList.Item(1..Count).

Dim WorkerList As New Collection

Public Sub Составить_Список_Сотрудников_вариант1()
    For Each Elem In Range("C:C")
        Elem = Trim(Elem)
        If Len(Elem) < 6 Then GoTo Continue
        If IsNumeric(Elem) Then GoTo Continue
        If Left(Elem, 5) = "0dis-" Then Elem = Right(Elem, Len(Elem) - 5)
        For Each Worker In WorkerList
            If UCase(Worker) = UCase(Elem) Then GoTo Continue
        Next
        WorkerList.Add Elem
Continue:
    Next
    Debug.Print "Всего"; WorkerList.Count; "сотрудников"
End Sub

Либо то же, но разделено на доп.функцию.

Dim WorkerList As New Collection
    
Public Sub Составить_Список_Сотрудников_вариант2()
    For Each Elem In Range("C:C")
        If ДобавитьСотрудника(Elem.Value) Then Debug.Print WorkerList.Item(WorkerList.Count)
    Next
    Debug.Print "Всего"; WorkerList.Count; "сотрудников"
End Sub

Function ДобавитьСотрудника(ФИО As String) As Boolean
    ДобавитьСотрудника = False
    ФИО = Trim(ФИО)                         ' Убрать лишние пробелы по краям
    If Len(ФИО) < 6 Then Exit Function      ' Слишком которкое ФИО
    If IsNumeric(ФИО) Then Exit Function    ' Числа не добавлять
    If Left(ФИО, 5) = "0dis-" Then ФИО = Right(ФИО, Len(ФИО) - 5) 'Отрезать "0dis-"

    For Each Worker In WorkerList
        If UCase(Worker) = UCase(ФИО) Then Exit Function
    Next
    WorkerList.Add ФИО
    ДобавитьСотрудника = True
End Function

Для самообучения, надеюсь, самое то. Не забудьте перед выполнением открыть лист "Данные601".


P.S. Debug.Print выводит в окно Immediate. Оно открывается по Ctrl-G.

[RubidoN]

Спасибо большое!
Вооот как правильно использовать функцию "IsNumeric"!!! Я был достаточно близок... Эх, Так всегда когда пытаешься понять сам как это работает.

Скорректировал немного свой код благодаря полученной вам информации, и получился приятный и гибкий к настройке скрипт. Всё подписал на человеческом языке для начинающих, чтобы могли воспользоваться. Скрипт самостоятельный, при аккуратном удалении не нужных вам условий и действий можно лучше подстроить под себя. Спасибо вам и удачи другим начинающим!

Sub OnlyFCs()
    Dim x, avArr, li As Long
    Dim avVals
    Dim rVals As Range, rResultCell As Range
 
    On Error Resume Next
    'Указываем адрес откуда извлечь данный список
    Set rVals = Sheets("Данные601").Range("$C:$C")
    
    If rVals.Count = 1 Then
        'Если указана только одна ячейка, завершение макроса.
        Exit Sub
    End If
    Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
        'Убирает пустые ячейки и столбцы
    If rVals Is Nothing Then
        'Если указаны пустые ячейки, завершение.
        Exit Sub
    End If
    avVals = rVals.Value
        'Указываем куда выводить результат
    Set rResultCell = Sheets("Экземпляры").Range("A2:A2000")
    If rResultCell Is Nothing Then
        'Если не указан диапазон или начальная ячейка ввода списка, завершение.
        Exit Sub
    End If
        'Указание размера массива ячеек
    ReDim avArr(1 To Rows.Count, 1 To 1)
        'Создание списка различных значений
    With New Collection
        On Error Resume Next
        For Each x In avVals 'Проверка каждого значения ячейки выбранного массива ячеек(avVals)
            x = Trim(x) 'Удаляет пробелы в начале и в конце текста ячейки
            If Left(x, 5) = "0dis-" Then x = Right(x, Len(x) - 5)   'Стирает текст "0dis-", если он содежится в !начале! текста ячейки.
                                                                    'Может быть любым нужным вам условием, но в этой строке нужно будет заменить цифры "5"
                                                                    'на число символов вашего условия
                If Len(x) > 6 Then 'Если больше 6 символов в ячейке
                    If IsNumeric(x) = False Then 'Если весь текст ячейки !не! может быть числом
                        .Add x, CStr(x)
                        'Добавить в список то что прошло все "Если"
                            If Err = 0 Then
                                li = li + 1
                                avArr(li, 1) = x
                            Else
                            'Очистка ошибок
                            Err.Clear
                            End If
                    End If
            End If
        Next
    End With
    'Запись результата на лист с указанной ячейки
    If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr
    With ActiveSheet.Sort 'Сортировка полученного списка по алфавиту
        .SortFields.Clear
        'Ниже указать первую ячейку сиска результатов
        .SortFields.Add Key:=Sheets("Экземпляры").Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A2:A2000") 'Указать весь список сортировки или его часть
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom 'Ориентация сортировки
        .Apply
    End With
End Sub